Index: trunk/share/tests/functional_tests/ref-output/vars.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output/vars.ref	(revision 8444)
+++ trunk/share/tests/functional_tests/ref-output/vars.ref	(revision 8445)
@@ -1,377 +1,378 @@
 ?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
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 ?unweighted = true
 ?negative_weights = false
 ?resonance_history = false
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 ?polarized_events = false
 ?colorize_subevt = false
 ?pacify = false
 ?out_advance = true
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 ?integration_timer = true
 ?check_grid_file = true
 ?vis_channels = false
 ?check_phs_file = true
 ?phs_only = false
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 ?normalize_bins = false
 ?y_log = false
 ?x_log = false
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 ?analysis_file_only = false
 ?keep_flavors_when_clustering = false
 ?sample_pacify = false
 ?sample_select = true
 ?read_raw = true
 ?write_raw = true
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 ?hepmc_output_cross_section = false
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 ?shower_verbose = false
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active* = false
 ?openmp_logging = false
 ?mpi_logging = false
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 ?virtual_collinear_resonance_aware = true
 ?openloops_use_cms = true
 ?openloops_switch_off_muon_yukawa = false
 ?disable_subtraction = false
 ?vis_fks_regions = false
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
+?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]
 [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"
 $phs_method = "default"
 $phs_file = ""
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 $sample = ""
 $sample_normalization = "auto"
 $rescan_input_format = "raw"
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 $dump_extension = "pset.dat"
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 $shower_method = "WHIZARD"
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 $hadronization_method = "PYTHIA6"
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 $blha_ew_scheme = "alpha_internal"
 $openloops_extra_cmd = ""
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 $gosam_fc = ""
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 [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 8444)
+++ trunk/share/tests/functional_tests/ref-output/process_log.ref	(revision 8445)
@@ -1,552 +1,553 @@
 ###############################################################################
  Process [scattering]: 'process_log_1_p1'
    Run ID        = ''
    Library name  = 'process_log_lib'
    Process index = 1
    Process components:
      1: 'process_log_1_p1_i1':   e-, e+ => m-, m+ [omega]
 ------------------------------------------------------------------------
 ###############################################################################
    Integral   =  8.3556567814E+03
    Error      =  3.2359019246E+00
    Accuracy   =  1.8972317270E-02
    Chi2       =  5.2032955661E-01
    Efficiency =  7.8315602603E-01
    T(10k evt) =  <time estimate>
 |=============================================================================|
 | It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
 |=============================================================================|
    1        800  8.3525258E+03  6.97E+00    0.08    0.02*  67.98
    2        800  8.3688100E+03  5.46E+00    0.07    0.02*  59.78
    3        800  8.3686236E+03  5.53E+00    0.07    0.02   78.45
 |-----------------------------------------------------------------------------|
    3       2400  8.3648733E+03  3.39E+00    0.04    0.02   78.45    2.06   3
 |-----------------------------------------------------------------------------|
    4        800  8.3602554E+03  5.63E+00    0.07    0.02   78.37
    5        800  8.3525628E+03  5.62E+00    0.07    0.02   78.30
    6        800  8.3541861E+03  5.56E+00    0.07    0.02*  78.32
 |-----------------------------------------------------------------------------|
    6       2400  8.3556568E+03  3.24E+00    0.04    0.02   78.32    0.52   3
 |=============================================================================|
 ###############################################################################
 | Phase-space chain (grove) weight history: (numbers in %)
 | chain |   1
 |=============================================================================|
       1 | 100
       2 | 100
       3 | 100
 |-----------------------------------------------------------------------------|
       4 | 100
       5 | 100
       6 | 100
 |=============================================================================|
 ###############################################################################
  Call statistics (current run):
    total       = 2400
    failed kin. = 0
    failed cuts = 0
    passed cuts = 0
    evaluated   = 2400
 ###############################################################################
  MC Integrator is VAMP
 ------------------------------------------------------------------------
  VAMP history (global):
  Pass #1:
  ------------------------------------------------------------------------------
  [vamp]   it   #calls     integral                 average           chi2  eff.
  [vamp]    1      800*  0.0000E+00(0.00E+00)  8.352526E+03(6.97E+00)  0.0 0.000
  [vamp]    2      800*  0.0000E+00(0.00E+00)  8.368810E+03(5.46E+00)  0.0 0.000
  [vamp]    3      800*  0.0000E+00(0.00E+00)  8.368624E+03(5.53E+00)  0.0 0.000
  ------------------------------------------------------------------------------
  Channel histories: [undefined]
  Pass #2:
  ------------------------------------------------------------------------------
  [vamp]   it   #calls     integral                 average           chi2  eff.
  [vamp]    1      800*  0.0000E+00(0.00E+00)  8.360255E+03(5.63E+00)  0.0 0.000
  [vamp]    2      800*  0.0000E+00(0.00E+00)  8.352563E+03(5.62E+00)  0.0 0.000
  [vamp]    3      800*  0.0000E+00(0.00E+00)  8.354186E+03(5.56E+00)  0.0 0.000
  ------------------------------------------------------------------------------
  Channel histories: [undefined]
 ------------------------------------------------------------------------
  Inequivalent channels:
    Channel 1:    Mult. = 1    Symm. = 1    Invar.: TF
  Equivalence list:
    Equivalent channels: 1 1
      Permutation: 1 2
      Mode:        3 0
 ------------------------------------------------------------------------
  Weights of channel chains (groves):
    1 1.0000000000
 ###############################################################################
  Beam data (collision):
    e-  (mass = 0.0000000E+00 GeV)
    e+  (mass = 0.0000000E+00 GeV)
    sqrts = 1.000000000000E+02 GeV
 ###############################################################################
    No cuts used.
 ------------------------------------------------------------------------
    No scale expression was given.
 ------------------------------------------------------------------------
    No factorization scale expression was given.
 ------------------------------------------------------------------------
    No renormalization scale expression was given.
 ------------------------------------------------------------------------
    No weight expression was given.
 ###############################################################################
  Summary of quantum-number states:
   + sign: allowed and contributing
   no +  : switched off at runtime
 ------------------------------------------------------------------------
  Term #1
    1  [f(11) h(-1) / f(-11) h(-1) / f(13) h(-1) / f(-13) h(-1)]
    2  [f(11) h(-1) / f(-11) h(-1) / f(13) h(-1) / f(-13) h(1)]
    3  [f(11) h(-1) / f(-11) h(-1) / f(13) h(1) / f(-13) h(-1)]
    4  [f(11) h(-1) / f(-11) h(-1) / f(13) h(1) / f(-13) h(1)]
  + 5  [f(11) h(-1) / f(-11) h(1) / f(13) h(-1) / f(-13) h(-1)]
  + 6  [f(11) h(-1) / f(-11) h(1) / f(13) h(-1) / f(-13) h(1)]
  + 7  [f(11) h(-1) / f(-11) h(1) / f(13) h(1) / f(-13) h(-1)]
  + 8  [f(11) h(-1) / f(-11) h(1) / f(13) h(1) / f(-13) h(1)]
  + 9  [f(11) h(1) / f(-11) h(-1) / f(13) h(-1) / f(-13) h(-1)]
  + 10  [f(11) h(1) / f(-11) h(-1) / f(13) h(-1) / f(-13) h(1)]
  + 11  [f(11) h(1) / f(-11) h(-1) / f(13) h(1) / f(-13) h(-1)]
  + 12  [f(11) h(1) / f(-11) h(-1) / f(13) h(1) / f(-13) h(1)]
    13  [f(11) h(1) / f(-11) h(1) / f(13) h(-1) / f(-13) h(-1)]
    14  [f(11) h(1) / f(-11) h(1) / f(13) h(-1) / f(-13) h(1)]
    15  [f(11) h(1) / f(-11) h(1) / f(13) h(1) / f(-13) h(-1)]
    16  [f(11) h(1) / f(-11) h(1) / f(13) h(1) / f(-13) h(1)]
 ###############################################################################
  Variable list:
 ------------------------------------------------------------------------
 ee =  3.000000000000E-01
 me =  0.000000000000E+00
 mmu =  1.000000000000E+01
 mtau =  1.777000000000E+00
 particle = PDG(0)
 E_LEPTON = PDG(11)
 e- = PDG(11)
 e1 = PDG(11)
 e+ = PDG(-11)
 E1 = PDG(-11)
 MU_LEPTON = PDG(13)
 m- = PDG(13)
 e2 = PDG(13)
 mu- = PDG(13)
 m+ = PDG(-13)
 E2 = PDG(-13)
 mu+ = PDG(-13)
 TAU_LEPTON = PDG(15)
 t- = PDG(15)
 e3 = PDG(15)
 ta- = PDG(15)
 tau- = PDG(15)
 t+ = PDG(-15)
 E3 = PDG(-15)
 ta+ = PDG(-15)
 tau+ = PDG(-15)
 PHOTON = PDG(22)
 A = PDG(22)
 gamma = PDG(22)
 photon = PDG(22)
 charged = PDG(11, 13, 15, -11, -13, -15)
 neutral = PDG(22)
 colored = PDG()
 sqrts =  1.000000000000E+02
 luminosity =  0.000000000000E+00
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging = true
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "QED"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "process_log_lib"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range = <real_range>
 real_precision = <real_precision>
 real_epsilon = <real_epsilon>
 real_tiny = <real_tiny>
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = ""
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "wood"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm = 0
 cambridge_algorithm = 1
 antikt_algorithm = 2
 genkt_algorithm = 3
 cambridge_for_passive_algorithm = 11
 genkt_for_passive_algorithm = 13
 ee_kt_algorithm = 50
 ee_genkt_algorithm = 53
 plugin_algorithm = 99
 undefined_jet_algorithm = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
 jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active = false
 openmp_num_threads_default = 1
 openmp_num_threads = 1
 ?openmp_logging = false
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
+?nlo_reuse_amplitudes_fks = false
 $fc = Fortran-compiler
 $fcflags = Fortran-flags
 ?rebuild_library = true
 ?recompile_library = false
 ?rebuild_phase_space = true
 ?rebuild_grids = true
 ?rebuild_events = true
 [undefined] num_id(process_log_1_p1) = [unknown integer]
 [undefined] integral(process_log_1_p1) = [unknown real]
 [undefined] error(process_log_1_p1) = [unknown real]
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
  Beam structure: [any particles]
 ###############################################################################
Index: trunk/share/tests/functional_tests/ref-output/show_4.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output/show_4.ref	(revision 8444)
+++ trunk/share/tests/functional_tests/ref-output/show_4.ref	(revision 8445)
@@ -1,1169 +1,1172 @@
 ?openmp_logging = false
 [user variable] foo = PDG(11, 13, 15)
 [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00)
 #####################################################
 QED.ee =>  3.028600000000E-01
 QED.me =>  5.110000000000E-04
 QED.mmu =>  1.057000000000E-01
 QED.mtau =>  1.777000000000E+00
 [undefined] sqrts = [unknown real]
 luminosity =  0.000000000000E+00
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 [undefined] circe1_sqrts = [unknown real]
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 lambda_qcd =  2.000000000000E-01
 helicity_selection_threshold =  1.000000000000E+10
 safety_factor =  1.000000000000E+00
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 tolerance =  0.000000000000E+00
 real_epsilon* = <real_epsilon>
 real_tiny* = <real_tiny>
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
 jet_dcut =  0.000000000000E+00
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_fixed_alphas =  0.000000000000E+00
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 blha_top_yukawa = -1.000000000000E+00
 ellis_sexton_scale = -1.000000000000E+00
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 real_partition_scale =  1.000000000000E+01
 #####################################################
 QED.charged* = PDG(11, 13, 15, -11, -13, -15)
 #####################################################
 [user variable] foo = PDG(11, 13, 15)
 #####################################################
 [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00)
 #####################################################
 $sf_trace_file = ""
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 $pdf_builtin_set = "CTEQ6L"
 $isr_handler_mode = "trivial"
 $epa_mode = "default"
 $epa_handler_mode = "trivial"
 $circe1_acc = "SBAND"
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 [undefined] $beam_events_file = [unknown string]
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 $model_name = "QED"
 $method = "omega"
 $restrictions = ""
 $omega_flags = ""
 $library_name = "show_4_lib"
 $rng_method = "tao"
 $event_file_version = ""
 $polarization_mode = "helicity"
 $out_file = ""
 $integration_method = "vamp"
 $run_id = ""
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 $phs_file = ""
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 $sample = ""
 $sample_normalization = "auto"
 $rescan_input_format = "raw"
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 $dump_extension = "pset.dat"
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 $shower_method = "WHIZARD"
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 $hadronization_method = "PYTHIA6"
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 $blha_ew_scheme = "alpha_internal"
 $openloops_extra_cmd = ""
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 $gosam_fc = ""
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 #####################################################
 ?sf_trace = false
 ?sf_allow_s_mapping = true
 ?hoppet_b_matching = false
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 ?isr_handler_keep_mass = true
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 ?circe1_generate = true
 ?circe1_map = true
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => true
 ?proc_as_run_id = true
 ?report_progress = true
 [user variable] ?me_verbose = false
 ?omega_write_phs_output = false
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 ?unweighted = true
 ?negative_weights = false
 ?resonance_history = false
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 ?polarized_events = false
 ?colorize_subevt = false
 ?pacify = false
 ?out_advance = true
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 ?integration_timer = true
 ?check_grid_file = true
 ?vis_channels = false
 ?check_phs_file = true
 ?phs_only = false
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 ?normalize_bins = false
 ?y_log = false
 ?x_log = false
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 ?analysis_file_only = false
 ?keep_flavors_when_clustering = false
 ?sample_pacify = false
 ?sample_select = true
 ?read_raw = true
 ?write_raw = true
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 ?hepmc_output_cross_section = false
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 ?shower_verbose = false
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active* = false
 ?openmp_logging = false
 ?mpi_logging = false
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 ?virtual_collinear_resonance_aware = true
 ?openloops_use_cms = true
 ?openloops_switch_off_muon_yukawa = false
 ?disable_subtraction = false
 ?vis_fks_regions = false
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
+?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
 ?logging => true
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "QED"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "show_4_lib"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = <real_range>
 real_precision* = <real_precision>
 real_epsilon* = <real_epsilon>
 real_tiny* = <real_tiny>
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = ""
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
 jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = false
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
+?nlo_reuse_amplitudes_fks = false
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 ?rebuild_library = true
 ?recompile_library = false
 ?rebuild_phase_space = true
 ?rebuild_grids = true
 ?rebuild_events = true
 #####################################################
 QED.ee =>  3.028600000000E-01
 QED.me =>  5.110000000000E-04
 QED.mmu =>  1.057000000000E-01
 QED.mtau =>  1.777000000000E+00
 QED.particle* = PDG(0)
 QED.E_LEPTON* = PDG(11)
 QED.e-* = PDG(11)
 QED.e1* = PDG(11)
 QED.e+* = PDG(-11)
 QED.E1* = PDG(-11)
 QED.MU_LEPTON* = PDG(13)
 QED.m-* = PDG(13)
 QED.e2* = PDG(13)
 QED.mu-* = PDG(13)
 QED.m+* = PDG(-13)
 QED.E2* = PDG(-13)
 QED.mu+* = PDG(-13)
 QED.TAU_LEPTON* = PDG(15)
 QED.t-* = PDG(15)
 QED.e3* = PDG(15)
 QED.ta-* = PDG(15)
 QED.tau-* = PDG(15)
 QED.t+* = PDG(-15)
 QED.E3* = PDG(-15)
 QED.ta+* = PDG(-15)
 QED.tau+* = PDG(-15)
 QED.PHOTON* = PDG(22)
 QED.A* = PDG(22)
 QED.gamma* = PDG(22)
 QED.photon* = PDG(22)
 QED.charged* = PDG(11, 13, 15, -11, -13, -15)
 QED.neutral* = PDG(22)
 QED.colored* = PDG()
 [undefined] sqrts = [unknown real]
 luminosity =  0.000000000000E+00
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => true
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "QED"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "show_4_lib"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = <real_range>
 real_precision* = <real_precision>
 real_epsilon* = <real_epsilon>
 real_tiny* = <real_tiny>
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = ""
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
 jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = false
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
+?nlo_reuse_amplitudes_fks = false
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 ?rebuild_library = true
 ?recompile_library = false
 ?rebuild_phase_space = true
 ?rebuild_grids = true
 ?rebuild_events = true
 [user variable] foo = PDG(11, 13, 15)
 [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00)
 | WHIZARD run finished.
 |=============================================================================|
Index: trunk/share/tests/unit_tests/ref-output/rt_data_2.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/rt_data_2.ref	(revision 8444)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_2.ref	(revision 8445)
@@ -1,492 +1,493 @@
 * Test output: rt_data_2
 *   Purpose: initialize global runtime data and fill contents
 
 ========================================================================
  Runtime data:
 ========================================================================
 gy =>  1.000000000000E+00
 ms =>  1.250000000000E+02
 ff =>  1.500000000000E+00
 mf* =>  1.875000000000E+02
 particle* = PDG(0)
 SCALAR* = PDG(25)
 s* = PDG(25)
 FERMION* = PDG(6)
 f* = PDG(6)
 fbar* = PDG(-6)
 F* = PDG(-6)
 charged* = PDG(6, -6)
 neutral* = PDG(25)
 colored* = PDG(6, -6)
 sqrts =  1.000000000000E+03
 luminosity =  3.300000000000E+01
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => false
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "Test"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 [undefined] $library_name = [unknown string]
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = 307
 real_precision* = 15
 real_epsilon* =  1.000000000000E-16
 real_tiny* =  1.000000000000-300
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = "run1"
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
 jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp = false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = true
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
+?nlo_reuse_amplitudes_fks = false
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 ========================================================================
 model "Test"
  ! md5sum = 'DB28187ADA60804A3CFC14A025DED784'
 
    parameter gy =  1.000000000000E+00
    parameter ms =  1.250000000000E+02
    parameter ff =  1.500000000000E+00
    external mf =  1.875000000000E+02
 
    particle SCALAR 25
      name "s"
      spin 0
      mass ms
    particle FERMION 6
      name "f"
      anti "fbar" "F"
      tex_anti "\bar{f}"
      spin 1/2  isospin 1/2  charge 2/3  color 3
      mass mf
 
    vertex "fbar" "f" "s"
    vertex "s" "s" "s"
 ========================================================================
  Process library stack: [empty]
 ========================================================================
  Beam structure: [any particles]
 ========================================================================
  Cuts:
 ------------------------------------------------------------------------
 +  SEQUENCE    <lexpr>  =  <lsinglet>
 +  SEQUENCE    <lsinglet>  =  <lterm>
 |  +  SEQUENCE    <lterm>  =  <all_fun>
 |  |  +  SEQUENCE    <all_fun>  =  all <lexpr> <pargs1>
 |  |  |  +  KEYWORD     all  = [keyword] all
 |  |  |  +  SEQUENCE    <lexpr>  =  <lsinglet>
 |  |  |  |  +  SEQUENCE    <lsinglet>  =  <lterm>
 |  |  |  |  |  +  SEQUENCE    <lterm>  =  <compared_expr>
 |  |  |  |  |  |  +  SEQUENCE    <compared_expr>  =  <expr> <comparison>
 |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <variable>
 |  |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = Pt
 |  |  |  |  |  |  |  +  SEQUENCE    <comparison>  =  '>' <expr>
 |  |  |  |  |  |  |  |  +  KEYWORD     '>'  = [keyword] >
 |  |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <integer_value>
 |  |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <integer_value>  =  <integer_literal>
 |  |  |  |  |  |  |  |  |  |  |  |  +  INTEGER     <integer_literal>  = 100
 |  |  |  +  ARGUMENTS   <pargs1>  =  <pexpr>
 |  |  |  |  +  SEQUENCE    <pexpr>  =  <pterm>
 |  |  |  |  |  +  SEQUENCE    <pterm>  =  <pexpr_src>
 |  |  |  |  |  |  +  SEQUENCE    <pexpr_src>  =  <unspecified_prt>
 |  |  |  |  |  |  |  +  SEQUENCE    <unspecified_prt>  =  <cexpr>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <cexpr>  =  <variable>
 |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = s
 ------------------------------------------------------------------------
  Scale: [undefined]
 ------------------------------------------------------------------------
  Factorization scale: [undefined]
 ------------------------------------------------------------------------
  Renormalization scale: [undefined]
 ------------------------------------------------------------------------
  Weight: [undefined]
 ========================================================================
  Event selection: [undefined]
 ------------------------------------------------------------------------
  Event reweighting factor: [undefined]
 ------------------------------------------------------------------------
  Event analysis: [undefined]
 ------------------------------------------------------------------------
  Event sample formats = foo_fmt, bar_fmt
 ------------------------------------------------------------------------
  Event callback: [undefined]
 ========================================================================
  Process stack: [empty]
 ========================================================================
  quit     : F
  quit_code: 0
 ========================================================================
  Logfile  : ''
 ========================================================================
 
 * Test output end: rt_data_2
Index: trunk/share/tests/unit_tests/ref-output/rt_data_3.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/rt_data_3.ref	(revision 8444)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_3.ref	(revision 8445)
@@ -1,1037 +1,1039 @@
 * Test output: rt_data_3
 *   Purpose: initialize global runtime data and fill contents;
 *            copy to local block and back
 
 * Init global data
 
 * Init and modify local data
 
  model associated   = T
  library associated = T
 
 ========================================================================
  Runtime data:
 ========================================================================
 gy =>  1.000000000000E+00
 ms =>  1.500000000000E+02
 ff =>  1.500000000000E+00
 mf* =>  2.250000000000E+02
 particle* = PDG(0)
 SCALAR* = PDG(25)
 s* = PDG(25)
 FERMION* = PDG(6)
 f* = PDG(6)
 fbar* = PDG(-6)
 F* = PDG(-6)
 charged* = PDG(6, -6)
 neutral* = PDG(25)
 colored* = PDG(6, -6)
 $model_name = "Test"
 $fc => "Local compiler"
 $fcflags => "Fortran-flags"
 $integration_method = "midpoint"
 $phs_method = "single"
 $library_name = "library_2"
 sqrts =  1.000000000000E+03
 luminosity =  3.300000000000E+01
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => false
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "Test"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "library_1"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = 307
 real_precision* = 15
 real_epsilon* =  1.000000000000E-16
 real_tiny* =  1.000000000000-300
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = "run1"
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
 jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp = false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = true
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
+?nlo_reuse_amplitudes_fks = false
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 ========================================================================
 model "Test"
  ! md5sum = 'DB28187ADA60804A3CFC14A025DED784'
 
    parameter gy =  1.000000000000E+00
    parameter ms =  1.500000000000E+02
    parameter ff =  1.500000000000E+00
    external mf =  2.250000000000E+02
 
    particle SCALAR 25
      name "s"
      spin 0
      mass ms
    particle FERMION 6
      name "f"
      anti "fbar" "F"
      tex_anti "\bar{f}"
      spin 1/2  isospin 1/2  charge 2/3  color 3
      mass mf
 
    vertex "fbar" "f" "s"
    vertex "s" "s" "s"
 ========================================================================
  Process library stack:
 ------------------------------------------------------------------------
  Process library: library_2
    external        = F
    makefile exists = F
    driver exists   = F
    code status     = o
 
  Process definition list: [empty]
 ------------------------------------------------------------------------
  Process library: library_1
    external        = F
    makefile exists = F
    driver exists   = F
    code status     = o
 
  Process definition list: [empty]
 ========================================================================
  Beam structure: s, s => pdf_builtin
 ========================================================================
  Cuts:
 ------------------------------------------------------------------------
 +  SEQUENCE    <lexpr>  =  <lsinglet>
 +  SEQUENCE    <lsinglet>  =  <lterm>
 |  +  SEQUENCE    <lterm>  =  <all_fun>
 |  |  +  SEQUENCE    <all_fun>  =  all <lexpr> <pargs1>
 |  |  |  +  KEYWORD     all  = [keyword] all
 |  |  |  +  SEQUENCE    <lexpr>  =  <lsinglet>
 |  |  |  |  +  SEQUENCE    <lsinglet>  =  <lterm>
 |  |  |  |  |  +  SEQUENCE    <lterm>  =  <compared_expr>
 |  |  |  |  |  |  +  SEQUENCE    <compared_expr>  =  <expr> <comparison>
 |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <variable>
 |  |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = Pt
 |  |  |  |  |  |  |  +  SEQUENCE    <comparison>  =  '>' <expr>
 |  |  |  |  |  |  |  |  +  KEYWORD     '>'  = [keyword] >
 |  |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <integer_value>
 |  |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <integer_value>  =  <integer_literal>
 |  |  |  |  |  |  |  |  |  |  |  |  +  INTEGER     <integer_literal>  = 100
 |  |  |  +  ARGUMENTS   <pargs1>  =  <pexpr>
 |  |  |  |  +  SEQUENCE    <pexpr>  =  <pterm>
 |  |  |  |  |  +  SEQUENCE    <pterm>  =  <pexpr_src>
 |  |  |  |  |  |  +  SEQUENCE    <pexpr_src>  =  <unspecified_prt>
 |  |  |  |  |  |  |  +  SEQUENCE    <unspecified_prt>  =  <cexpr>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <cexpr>  =  <variable>
 |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = s
 ------------------------------------------------------------------------
  Scale: [undefined]
 ------------------------------------------------------------------------
  Factorization scale: [undefined]
 ------------------------------------------------------------------------
  Renormalization scale: [undefined]
 ------------------------------------------------------------------------
  Weight: [undefined]
 ========================================================================
  Event selection: [undefined]
 ------------------------------------------------------------------------
  Event reweighting factor: [undefined]
 ------------------------------------------------------------------------
  Event analysis: [undefined]
 ------------------------------------------------------------------------
  Event sample formats = foo_fmt, bar_fmt
 ------------------------------------------------------------------------
  Event callback: NOP
 ========================================================================
  Process stack: [empty]
 ========================================================================
  [Processes from context environment:]
 ========================================================================
  Process stack: [empty]
 ========================================================================
  quit     : F
  quit_code: 0
 ========================================================================
  Logfile  : ''
 ========================================================================
 
 * Restore global data
 
  model associated   = T
  library associated = T
 
 ========================================================================
  Runtime data:
 ========================================================================
 gy =>  1.000000000000E+00
 ms =>  1.250000000000E+02
 ff =>  1.500000000000E+00
 mf* =>  1.875000000000E+02
 particle* = PDG(0)
 SCALAR* = PDG(25)
 s* = PDG(25)
 FERMION* = PDG(6)
 f* = PDG(6)
 fbar* = PDG(-6)
 F* = PDG(-6)
 charged* = PDG(6, -6)
 neutral* = PDG(25)
 colored* = PDG(6, -6)
 sqrts =  1.000000000000E+03
 luminosity =  3.300000000000E+01
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => false
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "Test"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "library_1"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = 307
 real_precision* = 15
 real_epsilon* =  1.000000000000E-16
 real_tiny* =  1.000000000000-300
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = "run1"
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
 jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp = false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = true
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
+?nlo_reuse_amplitudes_fks = false
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 ========================================================================
 model "Test"
  ! md5sum = 'DB28187ADA60804A3CFC14A025DED784'
 
    parameter gy =  1.000000000000E+00
    parameter ms =  1.250000000000E+02
    parameter ff =  1.500000000000E+00
    external mf =  1.875000000000E+02
 
    particle SCALAR 25
      name "s"
      spin 0
      mass ms
    particle FERMION 6
      name "f"
      anti "fbar" "F"
      tex_anti "\bar{f}"
      spin 1/2  isospin 1/2  charge 2/3  color 3
      mass mf
 
    vertex "fbar" "f" "s"
    vertex "s" "s" "s"
 ========================================================================
  Process library stack:
 ------------------------------------------------------------------------
  Process library: library_2
    external        = F
    makefile exists = F
    driver exists   = F
    code status     = o
 
  Process definition list: [empty]
 ------------------------------------------------------------------------
  Process library: library_1
    external        = F
    makefile exists = F
    driver exists   = F
    code status     = o
 
  Process definition list: [empty]
 ========================================================================
  Beam structure: s, s => pdf_builtin
 ========================================================================
  Cuts:
 ------------------------------------------------------------------------
 +  SEQUENCE    <lexpr>  =  <lsinglet>
 +  SEQUENCE    <lsinglet>  =  <lterm>
 |  +  SEQUENCE    <lterm>  =  <all_fun>
 |  |  +  SEQUENCE    <all_fun>  =  all <lexpr> <pargs1>
 |  |  |  +  KEYWORD     all  = [keyword] all
 |  |  |  +  SEQUENCE    <lexpr>  =  <lsinglet>
 |  |  |  |  +  SEQUENCE    <lsinglet>  =  <lterm>
 |  |  |  |  |  +  SEQUENCE    <lterm>  =  <compared_expr>
 |  |  |  |  |  |  +  SEQUENCE    <compared_expr>  =  <expr> <comparison>
 |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <variable>
 |  |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = Pt
 |  |  |  |  |  |  |  +  SEQUENCE    <comparison>  =  '>' <expr>
 |  |  |  |  |  |  |  |  +  KEYWORD     '>'  = [keyword] >
 |  |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <integer_value>
 |  |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <integer_value>  =  <integer_literal>
 |  |  |  |  |  |  |  |  |  |  |  |  +  INTEGER     <integer_literal>  = 100
 |  |  |  +  ARGUMENTS   <pargs1>  =  <pexpr>
 |  |  |  |  +  SEQUENCE    <pexpr>  =  <pterm>
 |  |  |  |  |  +  SEQUENCE    <pterm>  =  <pexpr_src>
 |  |  |  |  |  |  +  SEQUENCE    <pexpr_src>  =  <unspecified_prt>
 |  |  |  |  |  |  |  +  SEQUENCE    <unspecified_prt>  =  <cexpr>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <cexpr>  =  <variable>
 |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = s
 ------------------------------------------------------------------------
  Scale: [undefined]
 ------------------------------------------------------------------------
  Factorization scale: [undefined]
 ------------------------------------------------------------------------
  Renormalization scale: [undefined]
 ------------------------------------------------------------------------
  Weight: [undefined]
 ========================================================================
  Event selection: [undefined]
 ------------------------------------------------------------------------
  Event reweighting factor: [undefined]
 ------------------------------------------------------------------------
  Event analysis: [undefined]
 ------------------------------------------------------------------------
  Event sample formats = foo_fmt, bar_fmt
 ------------------------------------------------------------------------
  Event callback: [undefined]
 ========================================================================
  Process stack: [empty]
 ========================================================================
  quit     : F
  quit_code: 0
 ========================================================================
  Logfile  : ''
 ========================================================================
 
 * Cleanup
 
 * Test output end: rt_data_3
Index: trunk/share/tests/unit_tests/ref-output/rt_data_1.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/rt_data_1.ref	(revision 8444)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_1.ref	(revision 8445)
@@ -1,428 +1,429 @@
 * Test output: rt_data_1
 *   Purpose: initialize global runtime data
 
 ========================================================================
  Runtime data:
 ========================================================================
 [undefined] sqrts = [unknown real]
 luminosity =  0.000000000000E+00
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => false
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 [undefined] $model_name = [unknown string]
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 [undefined] $library_name = [unknown string]
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = 307
 real_precision* = 15
 real_epsilon* =  1.000000000000E-16
 real_tiny* =  1.000000000000-300
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = ""
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
 jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp = false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = true
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
+?nlo_reuse_amplitudes_fks = false
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 ========================================================================
  iterations = 2:5000:"gw", 3:20000
 ========================================================================
  Process library stack: [empty]
 ========================================================================
  Beam structure: [any particles]
 ========================================================================
  Cuts: [undefined]
 ------------------------------------------------------------------------
  Scale: [undefined]
 ------------------------------------------------------------------------
  Factorization scale: [undefined]
 ------------------------------------------------------------------------
  Renormalization scale: [undefined]
 ------------------------------------------------------------------------
  Weight: [undefined]
 ========================================================================
  Event selection: [undefined]
 ------------------------------------------------------------------------
  Event reweighting factor: [undefined]
 ------------------------------------------------------------------------
  Event analysis: [undefined]
 ------------------------------------------------------------------------
  Event callback: [undefined]
 ========================================================================
  Process stack: [empty]
 ========================================================================
  quit     : F
  quit_code: 0
 ========================================================================
  Logfile  : 'rt_data.log'
 ========================================================================
 
 * Test output end: rt_data_1
Index: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog	(revision 8444)
+++ trunk/ChangeLog	(revision 8445)
@@ -1,2103 +1,2106 @@
 ChangeLog -- Summary of changes to the WHIZARD package
 
 Use svn log to see detailed changes.
 
 	Version 3.0.0_beta+
 
+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/me_methods/me_methods.nw
===================================================================
--- trunk/src/me_methods/me_methods.nw	(revision 8444)
+++ trunk/src/me_methods/me_methods.nw	(revision 8445)
@@ -1,6965 +1,7010 @@
 % -*- 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)
     class(prc_core_t), intent(in) :: object
     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
    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_" // char (writer%model_name)
        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
    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')))
        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 [[fac_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 (fac_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]].
 <<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)
     class(prc_omega_t), intent(in) :: object
     real(default) :: alpha_qed
     alpha_qed = object%qed%get_alpha_qed ()
   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) :: fac_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)")
 
        fac_scale = 100
        write (u, "(1x,A,F4.0)")  "factorization scale = ", fac_scale
 
        amp = core%compute_amplitude &
             (1, p, 1, 6, 1, fac_scale, 100._default, alpha_qcd_forced)
 
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
 
        write (u, "(A)")
        write (u, "(A)")  "* Modify factorization scale and &
             &compute matrix element again"
        write (u, "(A)")
 
        fac_scale = 200
        write (u, "(1x,A,F4.0)")  "factorization scale = ", fac_scale
 
        amp = core%compute_amplitude &
             (1, p, 1, 6, 1, fac_scale, 100._default, 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, fac_scale, 100._default, 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
   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)
     class(prc_external_t), intent(in) :: object
     real(default) :: alpha_qed
     alpha_qed = object%qed%get_alpha_qed ()
   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')))
        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, fac_scale)
     class(prc_external_t), intent(in) :: object
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     real(default), intent(in) :: fac_scale
     real(default) :: alpha_qcd
     if (allocated (object%qcd%alpha)) then
        alpha_qcd = object%qcd%alpha%get (fac_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 (fac_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 (fac_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
 @
Index: trunk/src/whizard-core/whizard.nw
===================================================================
--- trunk/src/whizard-core/whizard.nw	(revision 8444)
+++ trunk/src/whizard-core/whizard.nw	(revision 8445)
@@ -1,29070 +1,29071 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD main code as NOWEB source
 \includemodulegraph{whizard-core}
 \chapter{Integration and Simulation}
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{User-controlled File I/O}
 
 The SINDARIN language includes commands that write output to file (input may
 be added later).  We identify files by their name, and manage the unit
 internally.  We need procedures for opening, closing, and printing files.
 
 <<[[user_files.f90]]>>=
 <<File header>>
 
 module user_files
 
 <<Use strings>>
   use io_units
   use diagnostics
   use ifiles
   use analysis
 
 <<Standard module head>>
 
 <<User files: public>>
 
 <<User files: types>>
 
 <<User files: interfaces>>
 
 contains
 
 <<User files: procedures>>
 
 end module user_files
 @ %def user_files
 @
 \subsection{The file type}
 This is a type that describes an open user file and its properties.  The entry
 is part of a doubly-linked list.
 <<User files: types>>=
   type :: file_t
      private
      type(string_t) :: name
      integer :: unit = -1
      logical :: reading = .false.
      logical :: writing = .false.
      type(file_t), pointer :: prev => null ()
      type(file_t), pointer :: next => null ()
   end type file_t
 
 @ %def file_t
 @ The initializer opens the file.
 <<User files: procedures>>=
   subroutine file_init (file, name, action, status, position)
     type(file_t), intent(out) :: file
     type(string_t), intent(in) :: name
     character(len=*), intent(in) :: action, status, position
     file%unit = free_unit ()
     file%name = name
     open (unit = file%unit, file = char (file%name), &
           action = action, status = status, position = position)
     select case (action)
     case ("read")
        file%reading = .true.
     case ("write")
        file%writing = .true.
     case ("readwrite")
        file%reading = .true.
        file%writing = .true.
     end select
   end subroutine file_init
 
 @ %def file_init
 @ The finalizer closes it.
 <<User files: procedures>>=
   subroutine file_final (file)
     type(file_t), intent(inout) :: file
     close (unit = file%unit)
     file%unit = -1
   end subroutine file_final
 
 @ %def file_final
 @ Check if a file is open with correct status.
 <<User files: procedures>>=
   function file_is_open (file, action) result (flag)
     logical :: flag
     type(file_t), intent(in) :: file
     character(*), intent(in) :: action
     select case (action)
     case ("read")
        flag = file%reading
     case ("write")
        flag = file%writing
     case ("readwrite")
        flag = file%reading .and. file%writing
     case default
        call msg_bug ("Checking file '" // char (file%name) &
             // "': illegal action specifier")
     end select
   end function file_is_open
 
 @ %def file_is_open
 @ Return the unit number of a file for direct access.  It should be checked
 first whether the file is open.
 <<User files: procedures>>=
   function file_get_unit (file) result (unit)
     integer :: unit
     type(file_t), intent(in) :: file
     unit = file%unit
   end function file_get_unit
 
 @ %def file_get_unit
 @ Write to the file.  Error if in wrong mode.  If there is no string, just
 write an empty record.  If there is a string, respect the [[advancing]]
 option.
 <<User files: procedures>>=
   subroutine file_write_string (file, string, advancing)
     type(file_t), intent(in) :: file
     type(string_t), intent(in), optional :: string
     logical, intent(in), optional :: advancing
     if (file%writing) then
        if (present (string)) then
           if (present (advancing)) then
              if (advancing) then
                 write (file%unit, "(A)")  char (string)
              else
                 write (file%unit, "(A)", advance="no")  char (string)
              end if
           else
              write (file%unit, "(A)")  char (string)
           end if
        else
           write (file%unit, *)
        end if
     else
        call msg_error ("Writing to file: File '" // char (file%name) &
             // "' is not open for writing.")
     end if
   end subroutine file_write_string
 
 @ %def file_write
 @ Write a whole ifile, line by line.
 <<User files: procedures>>=
   subroutine file_write_ifile (file, ifile)
     type(file_t), intent(in) :: file
     type(ifile_t), intent(in) :: ifile
     type(line_p) :: line
     call line_init (line, ifile)
     do while (line_is_associated (line))
        call file_write_string (file, line_get_string_advance (line))
     end do
   end subroutine file_write_ifile
 
 @ %def file_write_ifile
 @ Write an analysis object (or all objects) to an open file.
 <<User files: procedures>>=
   subroutine file_write_analysis (file, tag)
     type(file_t), intent(in) :: file
     type(string_t), intent(in), optional :: tag
     if (file%writing) then
        if (present (tag)) then
           call analysis_write (tag, unit = file%unit)
        else
           call analysis_write (unit = file%unit)
        end if
     else
        call msg_error ("Writing analysis to file: File '" // char (file%name) &
             // "' is not open for writing.")
     end if
   end subroutine file_write_analysis
 
 @ %def file_write_analysis
 @
 \subsection{The file list}
 We maintain a list of all open files and their attributes.  The list must be
 doubly-linked because we may delete entries.
 <<User files: public>>=
   public :: file_list_t
 <<User files: types>>=
   type :: file_list_t
      type(file_t), pointer :: first => null ()
      type(file_t), pointer :: last => null ()
   end type file_list_t
 
 @ %def file_list_t
 @ There is no initialization routine, but a finalizer which deletes all:
 <<User files: public>>=
   public :: file_list_final
 <<User files: procedures>>=
   subroutine file_list_final (file_list)
     type(file_list_t), intent(inout) :: file_list
     type(file_t), pointer :: current
     do while (associated (file_list%first))
        current => file_list%first
        file_list%first => current%next
        call file_final (current)
        deallocate (current)
     end do
     file_list%last => null ()
   end subroutine file_list_final
 
 @ %def file_list_final
 @ Find an entry in the list.  Return null pointer on failure.
 <<User files: procedures>>=
   function file_list_get_file_ptr (file_list, name) result (current)
     type(file_t), pointer :: current
     type(file_list_t), intent(in) :: file_list
     type(string_t), intent(in) :: name
     current => file_list%first
     do while (associated (current))
        if (current%name == name)  return
        current => current%next
     end do
   end function file_list_get_file_ptr
 
 @ %def file_list_get_file_ptr
 @ Check if a file is open, public version:
 <<User files: public>>=
   public :: file_list_is_open
 <<User files: procedures>>=
   function file_list_is_open (file_list, name, action) result (flag)
     logical :: flag
     type(file_list_t), intent(in) :: file_list
     type(string_t), intent(in) :: name
     character(len=*), intent(in) :: action
     type(file_t), pointer :: current
     current => file_list_get_file_ptr (file_list, name)
     if (associated (current)) then
        flag = file_is_open (current, action)
     else
        flag = .false.
     end if
   end function file_list_is_open
 
 @ %def file_list_is_open
 @ Return the unit number for a file.  It should be checked first whether the
 file is open.
 <<User files: public>>=
   public :: file_list_get_unit
 <<User files: procedures>>=
   function file_list_get_unit (file_list, name) result (unit)
     integer :: unit
     type(file_list_t), intent(in) :: file_list
     type(string_t), intent(in) :: name
     type(file_t), pointer :: current
     current => file_list_get_file_ptr (file_list, name)
     if (associated (current)) then
        unit = file_get_unit (current)
     else
        unit = -1
     end if
   end function file_list_get_unit
 
 @ %def file_list_get_unit
 @ Append a new file entry, i.e., open this file.  Error if it is
 already open.
 <<User files: public>>=
   public :: file_list_open
 <<User files: procedures>>=
   subroutine file_list_open (file_list, name, action, status, position)
     type(file_list_t), intent(inout) :: file_list
     type(string_t), intent(in) :: name
     character(len=*), intent(in) :: action, status, position
     type(file_t), pointer :: current
     if (.not. associated (file_list_get_file_ptr (file_list, name))) then
        allocate (current)
        call msg_message ("Opening file '" // char (name) // "' for output")
        call file_init (current, name, action, status, position)
        if (associated (file_list%last)) then
           file_list%last%next => current
           current%prev => file_list%last
        else
           file_list%first => current
        end if
        file_list%last => current
     else
        call msg_error ("Opening file: File '" // char (name) &
             // "' is already open.")
     end if
   end subroutine file_list_open
 
 @ %def file_list_open
 @ Delete a file entry, i.e., close this file.  Error if it is not open.
 <<User files: public>>=
   public :: file_list_close
 <<User files: procedures>>=
   subroutine file_list_close (file_list, name)
     type(file_list_t), intent(inout) :: file_list
     type(string_t), intent(in) :: name
     type(file_t), pointer :: current
     current => file_list_get_file_ptr (file_list, name)
     if (associated (current)) then
        if (associated (current%prev)) then
           current%prev%next => current%next
        else
           file_list%first => current%next
        end if
        if (associated (current%next)) then
           current%next%prev => current%prev
        else
           file_list%last => current%prev
        end if
        call msg_message ("Closing file '" // char (name) // "' for output")
        call file_final (current)
        deallocate (current)
     else
        call msg_error ("Closing file: File '" // char (name) &
             // "' is not open.")
     end if
   end subroutine file_list_close
 
 @ %def file_list_close
 @ Write a string to file.  Error if it is not open.
 <<User files: public>>=
   public :: file_list_write
 <<User files: interfaces>>=
   interface file_list_write
      module procedure file_list_write_string
      module procedure file_list_write_ifile
   end interface
 <<User files: procedures>>=
   subroutine file_list_write_string (file_list, name, string, advancing)
     type(file_list_t), intent(in) :: file_list
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: string
     logical, intent(in), optional :: advancing
     type(file_t), pointer :: current
     current => file_list_get_file_ptr (file_list, name)
     if (associated (current)) then
        call file_write_string (current, string, advancing)
     else
        call msg_error ("Writing to file: File '" // char (name) &
             // "'is not open.")
     end if
   end subroutine file_list_write_string
 
   subroutine file_list_write_ifile (file_list, name, ifile)
     type(file_list_t), intent(in) :: file_list
     type(string_t), intent(in) :: name
     type(ifile_t), intent(in) :: ifile
     type(file_t), pointer :: current
     current => file_list_get_file_ptr (file_list, name)
     if (associated (current)) then
        call file_write_ifile (current, ifile)
     else
        call msg_error ("Writing to file: File '" // char (name) &
             // "'is not open.")
     end if
   end subroutine file_list_write_ifile
 
 @ %def file_list_write
 @ Write an analysis object or all objects to data file.  Error if it is not
 open.  If the file name is empty, write to standard output.
 <<User files: public>>=
   public :: file_list_write_analysis
 <<User files: procedures>>=
   subroutine file_list_write_analysis (file_list, name, tag)
     type(file_list_t), intent(in) :: file_list
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: tag
     type(file_t), pointer :: current
     if (name == "") then
        if (present (tag)) then
           call analysis_write (tag)
        else
           call analysis_write
        end if
     else
        current => file_list_get_file_ptr (file_list, name)
        if (associated (current)) then
           call file_write_analysis (current, tag)
        else
           call msg_error ("Writing analysis to file: File '" // char (name) &
                // "' is not open.")
        end if
     end if
   end subroutine file_list_write_analysis
 
 @ %def file_list_write_analysis
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Runtime data}
 
 <<[[rt_data.f90]]>>=
 <<File header>>
 
 module rt_data
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_utils, only: write_separator
   use format_defs, only: FMT_19, FMT_12
   use system_dependencies
   use diagnostics
   use os_interface
   use lexers
   use parser
   use models
   use subevents
   use pdg_arrays
   use variables, only: var_list_t
   use process_libraries
   use prclib_stacks
   use prc_core, only: helicity_selection_t
   use beam_structures
   use event_base, only: event_callback_t
   use user_files
   use process_stacks
   use iterations
 
 <<Standard module head>>
 
 <<RT data: public>>
 
 <<RT data: types>>
 
 contains
 
 <<RT data: procedures>>
 
 end module rt_data
 @ %def rt_data
 @
 \subsection{Strategy for models and variables}
 The program manages its data via a main [[rt_data_t]] object.  During program
 flow, various commands create and use local [[rt_data_t]] objects.  Those
 transient blocks contain either pointers to global object or local copies
 which are deleted after use.
 
 Each [[rt_data_t]] object contains a variable list component.  This lists
 holds (local copies of) all kinds of intrinsic or user-defined variables.  The
 variable list is linked to the variable list contained in the local process
 library.  This, in turn, is linked to the variable list of the [[rt_data_t]]
 context, and so on.
 
 A variable lookup will thus be recursively delegated to the linked variable
 lists, until a match is found.  When modifying a variable which is not yet
 local, the program creates a local copy and uses this afterwards.  Thus, when
 the local [[rt_data_t]] object is deleted, the context value is recovered.
 
 Models are kept in a model list which is separate from the variable list.
 Otherwise, they are treated in a similar manner: the local list is linked to
 the context model list.  Model lookup is thus recursively delegated.  When a
 model or any part of it is modified, the model is copied to the local
 [[rt_data_t]] object, so the context model is not modified.  Commands such as
 [[integrate]] will create their own copy of the current model (and of the
 current variable list) at the point where they are executed.
 
 When a model is encountered for the first time, it is read from file.  The
 reading is automatically delegated to the global context.  Thus, this master
 copy survives until the main [[rt_data_t]] object is deleted, at program
 completion.
 
 If there is a currently active model, its variable list is linked to the main
 variable list.  Variable lookups will then start from the model variable
 list.  When the current model is switched, the new active model will get this
 link instead.  Consequently, a change to the current model is kept as long as
 this model has a local copy; it survives local model switches.  On the other
 hand, a parameter change in the current model doesn't affect any other model,
 even if the parameter name is identical.
 @
 \subsection{Container for parse nodes}
 The runtime data set contains a bunch of parse nodes (chunks of code
 that have not been compiled into evaluation trees but saved for later
 use).  We collect them here.
 
 This implementation has the useful effect that an assignment between two
 objects of this type will establish a pointer-target relationship for
 all components.
 <<RT data: types>>=
   type :: rt_parse_nodes_t
      type(parse_node_t), pointer :: cuts_lexpr => null ()
      type(parse_node_t), pointer :: scale_expr => null ()
      type(parse_node_t), pointer :: fac_scale_expr => null ()
      type(parse_node_t), pointer :: ren_scale_expr => null ()
      type(parse_node_t), pointer :: weight_expr => null ()
      type(parse_node_t), pointer :: selection_lexpr => null ()
      type(parse_node_t), pointer :: reweight_expr => null ()
      type(parse_node_t), pointer :: analysis_lexpr => null ()
      type(parse_node_p), dimension(:), allocatable :: alt_setup
    contains
    <<RT data: rt parse nodes: TBP>>
   end type rt_parse_nodes_t
 
 @ %def rt_parse_nodes_t
 @ Clear individual components.  The parse nodes are nullified.  No
 finalization needed since the pointer targets are part of the global
 parse tree.
 <<RT data: rt parse nodes: TBP>>=
   procedure :: clear => rt_parse_nodes_clear
 <<RT data: procedures>>=
   subroutine rt_parse_nodes_clear (rt_pn, name)
     class(rt_parse_nodes_t), intent(inout) :: rt_pn
     type(string_t), intent(in) :: name
     select case (char (name))
     case ("cuts")
        rt_pn%cuts_lexpr => null ()
     case ("scale")
        rt_pn%scale_expr => null ()
     case ("factorization_scale")
        rt_pn%fac_scale_expr => null ()
     case ("renormalization_scale")
        rt_pn%ren_scale_expr => null ()
     case ("weight")
        rt_pn%weight_expr => null ()
     case ("selection")
        rt_pn%selection_lexpr => null ()
     case ("reweight")
        rt_pn%reweight_expr => null ()
     case ("analysis")
        rt_pn%analysis_lexpr => null ()
     end select
   end subroutine rt_parse_nodes_clear
 
 @ %def rt_parse_nodes_clear
 @ Output for the parse nodes.
 <<RT data: rt parse nodes: TBP>>=
   procedure :: write => rt_parse_nodes_write
 <<RT data: procedures>>=
   subroutine rt_parse_nodes_write (object, unit)
     class(rt_parse_nodes_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     call wrt ("Cuts", object%cuts_lexpr)
     call write_separator (u)
     call wrt ("Scale", object%scale_expr)
     call write_separator (u)
     call wrt ("Factorization scale", object%fac_scale_expr)
     call write_separator (u)
     call wrt ("Renormalization scale", object%ren_scale_expr)
     call write_separator (u)
     call wrt ("Weight", object%weight_expr)
     call write_separator (u, 2)
     call wrt ("Event selection", object%selection_lexpr)
     call write_separator (u)
     call wrt ("Event reweighting factor", object%reweight_expr)
     call write_separator (u)
     call wrt ("Event analysis", object%analysis_lexpr)
     if (allocated (object%alt_setup)) then
        call write_separator (u, 2)
        write (u, "(1x,A,':')")  "Alternative setups"
        do i = 1, size (object%alt_setup)
           call write_separator (u)
           call wrt ("Commands", object%alt_setup(i)%ptr)
        end do
     end if
   contains
     subroutine wrt (title, pn)
       character(*), intent(in) :: title
       type(parse_node_t), intent(in), pointer :: pn
       if (associated (pn)) then
          write (u, "(1x,A,':')")  title
          call write_separator (u)
          call parse_node_write_rec (pn, u)
       else
          write (u, "(1x,A,':',1x,A)")  title, "[undefined]"
       end if
     end subroutine wrt
   end subroutine rt_parse_nodes_write
 
 @ %def rt_parse_nodes_write
 @ Screen output for individual components.  (This should eventually be more
 condensed, currently we print the internal representation tree.)
 <<RT data: rt parse nodes: TBP>>=
   procedure :: show => rt_parse_nodes_show
 <<RT data: procedures>>=
   subroutine rt_parse_nodes_show (rt_pn, name, unit)
     class(rt_parse_nodes_t), intent(in) :: rt_pn
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: unit
     type(parse_node_t), pointer :: pn
     integer :: u
     u = given_output_unit (unit)
     select case (char (name))
     case ("cuts")
        pn => rt_pn%cuts_lexpr
     case ("scale")
        pn => rt_pn%scale_expr
     case ("factorization_scale")
        pn => rt_pn%fac_scale_expr
     case ("renormalization_scale")
        pn => rt_pn%ren_scale_expr
     case ("weight")
        pn => rt_pn%weight_expr
     case ("selection")
        pn => rt_pn%selection_lexpr
     case ("reweight")
        pn => rt_pn%reweight_expr
     case ("analysis")
        pn => rt_pn%analysis_lexpr
     end select
     if (associated (pn)) then
        write (u, "(A,1x,A,1x,A)")  "Expression:", char (name), "(parse tree):"
        call parse_node_write_rec (pn, u)
     else
        write (u, "(A,1x,A,A)")  "Expression:", char (name), ": [undefined]"
     end if
   end subroutine rt_parse_nodes_show
 
 @ %def rt_parse_nodes_show
 @
 \subsection{The data type}
 This is a big data container which contains everything that is used and
 modified during the command flow.  A local copy of this can be used to
 temporarily override defaults.  The data set is transparent.
 <<RT data: public>>=
   public :: rt_data_t
 <<RT data: types>>=
   type :: rt_data_t
      type(lexer_t), pointer :: lexer => null ()
      type(rt_data_t), pointer :: context => null ()
      type(string_t), dimension(:), allocatable :: export
      type(var_list_t) :: var_list
      type(iterations_list_t) :: it_list
      type(os_data_t) :: os_data
      type(model_list_t) :: model_list
      type(model_t), pointer :: model => null ()
      logical :: model_is_copy = .false.
      type(model_t), pointer :: preload_model => null ()
      type(model_t), pointer :: fallback_model => null ()
      type(prclib_stack_t) :: prclib_stack
      type(process_library_t), pointer :: prclib => null ()
      type(beam_structure_t) :: beam_structure
      type(rt_parse_nodes_t) :: pn
      type(process_stack_t) :: process_stack
      type(string_t), dimension(:), allocatable :: sample_fmt
      class(event_callback_t), allocatable :: event_callback
      type(file_list_t), pointer :: out_files => null ()
      logical :: quit = .false.
      integer :: quit_code = 0
      type(string_t) :: logfile
      logical :: nlo_fixed_order = .false.
      logical, dimension(0:5) :: selected_nlo_parts = .false.
      integer, dimension(:), allocatable :: nlo_component
    contains
    <<RT data: rt data: TBP>>
   end type rt_data_t
 
 @ %def rt_data_t
 @
 \subsection{Output}
 <<RT data: rt data: TBP>>=
   procedure :: write => rt_data_write
 <<RT data: procedures>>=
   subroutine rt_data_write (object, unit, vars, pacify)
     class(rt_data_t), intent(in) :: object
     integer, intent(in), optional :: unit
     type(string_t), dimension(:), intent(in), optional :: vars
     logical, intent(in), optional :: pacify
     integer :: u, i
     u = given_output_unit (unit)
     call write_separator (u, 2)
     write (u, "(1x,A)")  "Runtime data:"
     if (object%get_n_export () > 0) then
        call write_separator (u, 2)
        write (u, "(1x,A)")  "Exported objects and variables:"
        call write_separator (u)
        call object%write_exports (u)
     end if
     if (present (vars)) then
        if (size (vars) /= 0) then
           call write_separator (u, 2)
           write (u, "(1x,A)")  "Selected variables:"
           call write_separator (u)
           call object%write_vars (u, vars)
        end if
     else
        call write_separator (u, 2)
        if (associated (object%model)) then
           call object%model%write_var_list (u, follow_link=.true.)
        else
           call object%var_list%write (u, follow_link=.true.)
        end if
     end if
     if (object%it_list%get_n_pass () > 0) then
        call write_separator (u, 2)
        write (u, "(1x)", advance="no")
        call object%it_list%write (u)
     end if
     if (associated (object%model)) then
        call write_separator (u, 2)
        call object%model%write (u)
     end if
     call object%prclib_stack%write (u)
     call object%beam_structure%write (u)
     call write_separator (u, 2)
     call object%pn%write (u)
     if (allocated (object%sample_fmt)) then
        call write_separator (u)
        write (u, "(1x,A)", advance="no")  "Event sample formats = "
        do i = 1, size (object%sample_fmt)
           if (i > 1)  write (u, "(A,1x)", advance="no")  ","
           write (u, "(A)", advance="no")  char (object%sample_fmt(i))
        end do
        write (u, "(A)")
     end if
     call write_separator (u)
     write (u, "(1x,A)", advance="no")  "Event callback:"
     if (allocated (object%event_callback)) then
        call object%event_callback%write (u)
     else
        write (u, "(1x,A)")  "[undefined]"
     end if
     call object%process_stack%write (u, pacify)
     write (u, "(1x,A,1x,L1)")  "quit     :", object%quit
     write (u, "(1x,A,1x,I0)")  "quit_code:", object%quit_code
     call write_separator (u, 2)
     write (u, "(1x,A,1x,A)")   "Logfile  :", "'" // trim (char (object%logfile)) // "'"
     call write_separator (u, 2)
   end subroutine rt_data_write
 
 @ %def rt_data_write
 @ Write only selected variables.
 <<RT data: rt data: TBP>>=
   procedure :: write_vars => rt_data_write_vars
 <<RT data: procedures>>=
   subroutine rt_data_write_vars (object, unit, vars)
     class(rt_data_t), intent(in), target :: object
     integer, intent(in), optional :: unit
     type(string_t), dimension(:), intent(in) :: vars
     type(var_list_t), pointer :: var_list
     integer :: u, i
     u = given_output_unit (unit)
     var_list => object%get_var_list_ptr ()
     do i = 1, size (vars)
        associate (var => vars(i))
          if (var_list%contains (var, follow_link=.true.)) then
             call var_list%write_var (var, unit = u, &
                  follow_link = .true., defined=.true.)
          end if
        end associate
     end do
   end subroutine rt_data_write_vars
 
 @ %def rt_data_write_vars
 @ Write only the model list.
 <<RT data: rt data: TBP>>=
   procedure :: write_model_list => rt_data_write_model_list
 <<RT data: procedures>>=
   subroutine rt_data_write_model_list (object, unit)
     class(rt_data_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     call object%model_list%write (u)
   end subroutine rt_data_write_model_list
 
 @ %def rt_data_write_model_list
 @ Write only the library stack.
 <<RT data: rt data: TBP>>=
   procedure :: write_libraries => rt_data_write_libraries
 <<RT data: procedures>>=
   subroutine rt_data_write_libraries (object, unit, libpath)
     class(rt_data_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: libpath
     integer :: u
     u = given_output_unit (unit)
     call object%prclib_stack%write (u, libpath)
   end subroutine rt_data_write_libraries
 
 @ %def rt_data_write_libraries
 @ Write only the beam data.
 <<RT data: rt data: TBP>>=
   procedure :: write_beams => rt_data_write_beams
 <<RT data: procedures>>=
   subroutine rt_data_write_beams (object, unit)
     class(rt_data_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     call write_separator (u, 2)
     call object%beam_structure%write (u)
     call write_separator (u, 2)
   end subroutine rt_data_write_beams
 
 @ %def rt_data_write_beams
 @ Write only the process and event expressions.
 <<RT data: rt data: TBP>>=
   procedure :: write_expr => rt_data_write_expr
 <<RT data: procedures>>=
   subroutine rt_data_write_expr (object, unit)
     class(rt_data_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     call write_separator (u, 2)
     call object%pn%write (u)
     call write_separator (u, 2)
   end subroutine rt_data_write_expr
 
 @ %def rt_data_write_expr
 @ Write only the process stack.
 <<RT data: rt data: TBP>>=
   procedure :: write_process_stack => rt_data_write_process_stack
 <<RT data: procedures>>=
   subroutine rt_data_write_process_stack (object, unit)
     class(rt_data_t), intent(in) :: object
     integer, intent(in), optional :: unit
     call object%process_stack%write (unit)
   end subroutine rt_data_write_process_stack
 
 @ %def rt_data_write_process_stack
 @
 <<RT data: rt data: TBP>>=
   procedure :: write_var_descriptions => rt_data_write_var_descriptions
 <<RT data: procedures>>=
   subroutine rt_data_write_var_descriptions (rt_data, unit, ascii_output)
     class(rt_data_t), intent(in) :: rt_data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: ascii_output
     integer :: u
     logical :: ao
     u = given_output_unit (unit)
     ao = .false.;  if (present (ascii_output))  ao = ascii_output
     call rt_data%var_list%write (u, follow_link=.true., &
          descriptions=.true., ascii_output=ao)
   end subroutine rt_data_write_var_descriptions
 
 @ %def rt_data_write_var_descriptions
 @
 <<RT data: rt data: TBP>>=
   procedure :: show_description_of_string => rt_data_show_description_of_string
 <<RT data: procedures>>=
   subroutine rt_data_show_description_of_string (rt_data, string, &
          unit, ascii_output)
     class(rt_data_t), intent(in) :: rt_data
     type(string_t), intent(in) :: string
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: ascii_output
     integer :: u
     logical :: ao
     u = given_output_unit (unit)
     ao = .false.;  if (present (ascii_output))  ao = ascii_output
     call rt_data%var_list%write_var (string, unit=u, follow_link=.true., &
          defined=.false., descriptions=.true., ascii_output=ao)
   end subroutine rt_data_show_description_of_string
 
 @ %def rt_data_show_description_of_string
 @
 \subsection{Clear}
 The [[clear]] command can remove the contents of various subobjects.
 The objects themselves should stay.
 <<RT data: rt data: TBP>>=
   procedure :: clear_beams => rt_data_clear_beams
 <<RT data: procedures>>=
   subroutine rt_data_clear_beams (global)
     class(rt_data_t), intent(inout) :: global
     call global%beam_structure%final_sf ()
     call global%beam_structure%final_pol ()
     call global%beam_structure%final_mom ()
   end subroutine rt_data_clear_beams
 
 @ %def rt_data_clear_beams
 @
 \subsection{Initialization}
 Initialize runtime data.  This defines special variables such as
 [[sqrts]], and should be done only for the instance that is actually
 global.   Local copies will inherit the special variables.
 
 We link the global variable list to the process stack variable list,
 so the latter is always available (and kept global).
 <<RT data: rt data: TBP>>=
   procedure :: global_init => rt_data_global_init
 <<RT data: procedures>>=
   subroutine rt_data_global_init (global, paths, logfile)
     class(rt_data_t), intent(out), target :: global
     type(paths_t), intent(in), optional :: paths
     type(string_t), intent(in), optional :: logfile
     integer :: seed
     call global%os_data%init (paths)
     if (present (logfile)) then
        global%logfile = logfile
     else
        global%logfile = ""
     end if
     allocate (global%out_files)
     call system_clock (seed)
     call global%var_list%init_defaults (seed, paths)
     call global%init_pointer_variables ()
     call global%process_stack%init_var_list (global%var_list)
   end subroutine rt_data_global_init
 
 @ %def rt_data_global_init
 @
 \subsection{Local copies}
 This is done at compile time when a local copy of runtime data is
 needed: Link the variable list and initialize all derived parameters.
 This allows for synchronizing them with local variable changes without
 affecting global data.
 
 Also re-initialize pointer variables, so they point to local copies of
 their targets.
 <<RT data: rt data: TBP>>=
   procedure :: local_init => rt_data_local_init
 <<RT data: procedures>>=
   subroutine rt_data_local_init (local, global, env)
     class(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(in), target :: global
     integer, intent(in), optional :: env
     local%context => global
     call local%process_stack%link (global%process_stack)
     call local%process_stack%init_var_list (local%var_list)
     call local%process_stack%link_var_list (global%var_list)
     call local%var_list%append_string (var_str ("$model_name"), &
          var_str (""), intrinsic=.true.)
     call local%init_pointer_variables ()
     local%fallback_model => global%fallback_model
     local%os_data = global%os_data
     local%logfile = global%logfile
     call local%model_list%link (global%model_list)
     local%model => global%model
     if (associated (local%model)) then
        call local%model%link_var_list (local%var_list)
     end if
     if (allocated (global%event_callback)) then
        allocate (local%event_callback, source = global%event_callback)
     end if
   end subroutine rt_data_local_init
 
 @ %def rt_data_local_init
 @ These variables point to objects which get local copies:
 <<RT data: rt data: TBP>>=
   procedure :: init_pointer_variables => rt_data_init_pointer_variables
 <<RT data: procedures>>=
   subroutine rt_data_init_pointer_variables (local)
     class(rt_data_t), intent(inout), target :: local
     logical, target, save :: known = .true.
     call local%var_list%append_string_ptr (var_str ("$fc"), &
          local%os_data%fc, known, intrinsic=.true., &
          description=var_str('This string variable gives the ' // &
          '\ttt{Fortran} compiler used within \whizard. It can ' // &
          'only be accessed, not set by the user. (cf. also ' // &
          '\ttt{\$fcflags})'))
     call local%var_list%append_string_ptr (var_str ("$fcflags"), &
          local%os_data%fcflags, known, intrinsic=.true., &
          description=var_str('This string variable gives the ' // &
          'compiler flags for the \ttt{Fortran} compiler used ' // &
          'within \whizard. It can only be accessed, not set by ' // &
          'the user. (cf. also \ttt{\$fc})'))
   end subroutine rt_data_init_pointer_variables
 
 @ %def rt_data_init_pointer_variables
 @ This is done at execution time: Copy data, transfer pointers.
 [[local]] has intent(inout) because its local variable list has
 already been prepared by the previous routine.
 
 To be pedantic, the local pointers to model and library should point
 to the entries in the local copies.  (However, as long as these are
 just shallow copies with identical content, this is actually
 irrelevant.)
 
 The process library and process stacks behave as global objects.  The
 copies of the process library and process stacks should be shallow
 copies, so the contents stay identical.  Since objects may be pushed
 on the stack in the local environment, upon restoring the global
 environment, we should reverse the assignment.  Then the added stack
 elements will end up on the global stack.  (This should be
 reconsidered in a parallel environment.)
 <<RT data: rt data: TBP>>=
   procedure :: activate => rt_data_activate
 <<RT data: procedures>>=
   subroutine rt_data_activate (local)
     class(rt_data_t), intent(inout), target :: local
     class(rt_data_t), pointer :: global
     global => local%context
     if (associated (global)) then
        local%lexer => global%lexer
        call global%copy_globals (local)
        local%os_data = global%os_data
        local%logfile = global%logfile
        if (associated (global%prclib)) then
           local%prclib => &
                local%prclib_stack%get_library_ptr (global%prclib%get_name ())
        end if
        call local%import_values ()
        call local%process_stack%link (global%process_stack)
        local%it_list = global%it_list
        local%beam_structure = global%beam_structure
        local%pn = global%pn
        if (allocated (local%sample_fmt))  deallocate (local%sample_fmt)
        if (allocated (global%sample_fmt)) then
           allocate (local%sample_fmt (size (global%sample_fmt)), &
                source = global%sample_fmt)
        end if
        local%out_files => global%out_files
        local%model => global%model
        local%model_is_copy = .false.
     else if (.not. associated (local%model)) then
        local%model => local%preload_model
        local%model_is_copy = .false.
     end if
     if (associated (local%model)) then
        call local%model%link_var_list (local%var_list)
        call local%var_list%set_string (var_str ("$model_name"), &
             local%model%get_name (), is_known = .true.)
     else
        call local%var_list%set_string (var_str ("$model_name"), &
             var_str (""), is_known = .false.)
     end if
   end subroutine rt_data_activate
 
 @ %def rt_data_activate
 @ Restore the previous state of data, without actually finalizing the local
 environment.  We also clear the local process stack.  Some local modifications
 (model list and process library stack) are communicated to the global context,
 if there is any.
 
 If the [[keep_local]] flag is set, we want to retain current settings in
 the local environment.  In particular, we create an instance of the currently
 selected model (which thus becomes separated from the model library!).
 The local variables are also kept.
 <<RT data: rt data: TBP>>=
   procedure :: deactivate => rt_data_deactivate
 <<RT data: procedures>>=
   subroutine rt_data_deactivate (local, global, keep_local)
     class(rt_data_t), intent(inout), target :: local
     class(rt_data_t), intent(inout), optional, target :: global
     logical, intent(in), optional :: keep_local
     type(string_t) :: local_model, local_scheme
     logical :: same_model, delete
     delete = .true.;  if (present (keep_local))  delete = .not. keep_local
     if (present (global)) then
        if (associated (global%model) .and. associated (local%model)) then
           local_model = local%model%get_name ()
           if (global%model%has_schemes ()) then
              local_scheme = local%model%get_scheme ()
              same_model = &
                   global%model%matches (local_model, local_scheme)
           else
              same_model = global%model%matches (local_model)
           end if
        else
           same_model = .false.
        end if
        if (delete) then
           call local%process_stack%clear ()
           call local%unselect_model ()
           call local%unset_values ()
        else if (associated (local%model)) then
           call local%ensure_model_copy ()
        end if
        if (.not. same_model .and. associated (global%model)) then
           if (global%model%has_schemes ()) then
              call msg_message ("Restoring model '" // &
                   char (global%model%get_name ()) // "', scheme '" // &
                   char (global%model%get_scheme ()) // "'")
           else
              call msg_message ("Restoring model '" // &
                   char (global%model%get_name ()) // "'")
           end if
        end if
        if (associated (global%model)) then
           call global%model%link_var_list (global%var_list)
        end if
        call global%restore_globals (local)
     else
        call local%unselect_model ()
     end if
   end subroutine rt_data_deactivate
 
 @ %def rt_data_deactivate
 @ This imports the global objects for which local modifications
 should be kept.  Currently, this is only the process library stack.
 <<RT data: rt data: TBP>>=
   procedure :: copy_globals => rt_data_copy_globals
 <<RT data: procedures>>=
   subroutine rt_data_copy_globals (global, local)
     class(rt_data_t), intent(in) :: global
     class(rt_data_t), intent(inout) :: local
     local%prclib_stack = global%prclib_stack
   end subroutine rt_data_copy_globals
 
 @ %def rt_data_copy_globals
 @ This restores global objects for which local modifications
 should be kept.  May also modify (remove) the local objects.
 <<RT data: rt data: TBP>>=
   procedure :: restore_globals => rt_data_restore_globals
 <<RT data: procedures>>=
   subroutine rt_data_restore_globals (global, local)
     class(rt_data_t), intent(inout) :: global
     class(rt_data_t), intent(inout) :: local
     global%prclib_stack = local%prclib_stack
     call local%handle_exports (global)
   end subroutine rt_data_restore_globals
 
 @ %def rt_data_restore_globals
 @
 \subsection{Exported objects}
 Exported objects are transferred to the global state when a local environment
 is closed.  (For the top-level global data set, there is no effect.)
 
 The current implementation handles only the [[results]] object, which resolves
 to the local process stack.  The stack elements are appended to the global
 stack without modification, the local stack becomes empty.
 
 Write names of objects to be exported:
 <<RT data: rt data: TBP>>=
   procedure :: write_exports => rt_data_write_exports
 <<RT data: procedures>>=
   subroutine rt_data_write_exports (rt_data, unit)
     class(rt_data_t), intent(in) :: rt_data
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     do i = 1, rt_data%get_n_export ()
        write (u, "(A)")  char (rt_data%export(i))
     end do
   end subroutine rt_data_write_exports
 
 @ %def rt_data_write_exports
 @ The number of entries in the export list.
 <<RT data: rt data: TBP>>=
   procedure :: get_n_export => rt_data_get_n_export
 <<RT data: procedures>>=
   function rt_data_get_n_export (rt_data) result (n)
     class(rt_data_t), intent(in) :: rt_data
     integer :: n
     if (allocated (rt_data%export)) then
        n = size (rt_data%export)
     else
        n = 0
     end if
   end function rt_data_get_n_export
 
 @ %def rt_data_get_n_export
 @ Return a specific export
 @ Append new names to the export list.  If a duplicate occurs, do not transfer
 it.
 <<RT data: rt data: TBP>>=
   procedure :: append_exports => rt_data_append_exports
 <<RT data: procedures>>=
   subroutine rt_data_append_exports (rt_data, export)
     class(rt_data_t), intent(inout) :: rt_data
     type(string_t), dimension(:), intent(in) :: export
     logical, dimension(:), allocatable :: mask
     type(string_t), dimension(:), allocatable :: tmp
     integer :: i, j, n
     if (.not. allocated (rt_data%export))  allocate (rt_data%export (0))
     n = size (rt_data%export)
     allocate (mask (size (export)), source=.false.)
     do i = 1, size (export)
        mask(i) = all (export(i) /= rt_data%export) &
             .and. all (export(i) /= export(:i-1))
     end do
     if (count (mask) > 0) then
        allocate (tmp (n + count (mask)))
        tmp(1:n) = rt_data%export(:)
        j = n
        do i = 1, size (export)
           if (mask(i)) then
              j = j + 1
              tmp(j) = export(i)
           end if
        end do
        call move_alloc (from=tmp, to=rt_data%export)
     end if
   end subroutine rt_data_append_exports
 
 @ %def rt_data_append_exports
 @ Transfer export-objects from the [[local]] rt data to the [[global]] rt
 data, as far as supported.
 <<RT data: rt data: TBP>>=
   procedure :: handle_exports => rt_data_handle_exports
 <<RT data: procedures>>=
   subroutine rt_data_handle_exports (local, global)
     class(rt_data_t), intent(inout), target :: local
     class(rt_data_t), intent(inout), target :: global
     type(string_t) :: export
     integer :: i
     if (local%get_n_export () > 0) then
        do i = 1, local%get_n_export ()
           export = local%export(i)
           select case (char (export))
           case ("results")
              call msg_message ("Exporting integration results &
                   &to outer environment")
              call local%transfer_process_stack (global)
           case default
              call msg_bug ("handle exports: '" &
                   // char (export) // "' unsupported")
           end select
        end do
     end if
   end subroutine rt_data_handle_exports
 
 @ %def rt_data_handle_exports
 @ Export the process stack.  One-by-one, take the last process from the local
 stack and push it on the global stack.  Also handle the corresponding result
 variables: append if the process did not exist yet in the global stack,
 otherwise update.
 
 TODO: result variables do not work that way yet, require initialization in the
 global variable list.
 <<RT data: rt data: TBP>>=
   procedure :: transfer_process_stack => rt_data_transfer_process_stack
 <<RT data: procedures>>=
   subroutine rt_data_transfer_process_stack (local, global)
     class(rt_data_t), intent(inout), target :: local
     class(rt_data_t), intent(inout), target :: global
     type(process_entry_t), pointer :: process
     type(string_t) :: process_id
     do
        call local%process_stack%pop_last (process)
        if (.not. associated (process))  exit
        process_id = process%get_id ()
        call global%process_stack%push (process)
        call global%process_stack%fill_result_vars (process_id)
        call global%process_stack%update_result_vars &
             (process_id, global%var_list)
     end do
   end subroutine rt_data_transfer_process_stack
 
 @ %def rt_data_transfer_process_stack
 @
 \subsection{Finalization}
 Finalizer for the variable list and the structure-function list.
 This is done only for the global RT dataset; local copies contain
 pointers to this and do not need a finalizer.
 <<RT data: rt data: TBP>>=
   procedure :: final => rt_data_global_final
 <<RT data: procedures>>=
   subroutine rt_data_global_final (global)
     class(rt_data_t), intent(inout) :: global
     call global%process_stack%final ()
     call global%prclib_stack%final ()
     call global%model_list%final ()
     call global%var_list%final (follow_link=.false.)
     if (associated (global%out_files)) then
        call file_list_final (global%out_files)
        deallocate (global%out_files)
     end if
   end subroutine rt_data_global_final
 
 @ %def rt_data_global_final
 @ The local copy needs a finalizer for the variable list, which consists
 of local copies.  This finalizer is called only when the local
 environment is finally discarded.  (Note that the process stack should
 already have been cleared after execution, which can occur many times
 for the same local environment.)
 <<RT data: rt data: TBP>>=
   procedure :: local_final => rt_data_local_final
 <<RT data: procedures>>=
   subroutine rt_data_local_final (local)
     class(rt_data_t), intent(inout) :: local
     call local%process_stack%clear ()
     call local%model_list%final ()
     call local%var_list%final (follow_link=.false.)
   end subroutine rt_data_local_final
 
 @ %def rt_data_local_final
 @
 \subsection{Model Management}
 Read a model, so it becomes available for activation.  No variables or model
 copies, this is just initialization.
 
 If this is a local environment, the model will be automatically read into the
 global context.
 <<RT data: rt data: TBP>>=
   procedure :: read_model => rt_data_read_model
 <<RT data: procedures>>=
   subroutine rt_data_read_model (global, name, model, scheme)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: scheme
     type(model_t), pointer, intent(out) :: model
     type(string_t) :: filename
     filename = name // ".mdl"
     call global%model_list%read_model &
          (name, filename, global%os_data, model, scheme)
   end subroutine rt_data_read_model
 
 @ %def rt_data_read_model
 @ Read a UFO model.  Create it on the fly if necessary.
 <<RT data: rt data: TBP>>=
   procedure :: read_ufo_model => rt_data_read_ufo_model
 <<RT data: procedures>>=
   subroutine rt_data_read_ufo_model (global, name, model, ufo_path)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     type(model_t), pointer, intent(out) :: model
     type(string_t), intent(in), optional :: ufo_path
     type(string_t) :: filename
     filename = name // ".ufo.mdl"
     call global%model_list%read_model &
          (name, filename, global%os_data, model, ufo=.true., ufo_path=ufo_path)
   end subroutine rt_data_read_ufo_model
 
 @ %def rt_data_read_ufo_model
 @ Initialize the fallback model.  This model is used
 whenever the current model does not describe all physical particles
 (hadrons, mainly).  It is not supposed to be modified, and the pointer
 should remain linked to this model.
 <<RT data: rt data: TBP>>=
   procedure :: init_fallback_model => rt_data_init_fallback_model
 <<RT data: procedures>>=
   subroutine rt_data_init_fallback_model (global, name, filename)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name, filename
     call global%model_list%read_model &
          (name, filename, global%os_data, global%fallback_model)
   end subroutine rt_data_init_fallback_model
 
 @ %def rt_data_init_fallback_model
 @
 Activate a model: assign the current-model pointer and set the model name in
 the variable list.  If necessary, read the model from file.  Link the global
 variable list to the model variable list.
 <<RT data: rt data: TBP>>=
   procedure :: select_model => rt_data_select_model
 <<RT data: procedures>>=
   subroutine rt_data_select_model (global, name, scheme, ufo, ufo_path)
     class(rt_data_t), intent(inout), target :: global
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: scheme
     logical, intent(in), optional :: ufo
     type(string_t), intent(in), optional :: ufo_path
     logical :: same_model, ufo_model
     ufo_model = .false.;  if (present (ufo))  ufo_model = ufo
     if (associated (global%model)) then
        same_model = global%model%matches (name, scheme, ufo)
     else
        same_model = .false.
     end if
     if (.not. same_model) then
        global%model => global%model_list%get_model_ptr (name, scheme, ufo)
        if (.not. associated (global%model)) then
           if (ufo_model) then
              call global%read_ufo_model (name, global%model, ufo_path)
           else
              call global%read_model (name, global%model)
           end if
           global%model_is_copy = .false.
        else if (associated (global%context)) then
           global%model_is_copy = &
                global%model_list%model_exists (name, scheme, ufo, &
                follow_link=.false.)
        else
           global%model_is_copy = .false.
        end if
     end if
     if (associated (global%model)) then
        call global%model%link_var_list (global%var_list)
        call global%var_list%set_string (var_str ("$model_name"), &
             name, is_known = .true.)
        if (global%model%is_ufo_model ()) then
           call msg_message ("Switching to model '" // char (name) // "' " &
                // "(generated from UFO source)")
        else if (global%model%has_schemes ()) then
           call msg_message ("Switching to model '" // char (name) // "', " &
                // "scheme '" // char (global%model%get_scheme ()) // "'")
        else
           call msg_message ("Switching to model '" // char (name) // "'")
        end if
     else
        call global%var_list%set_string (var_str ("$model_name"), &
             var_str (""), is_known = .false.)
     end if
   end subroutine rt_data_select_model
 
 @ %def rt_data_select_model
 @
 Remove the model link.  Do not unset the model name variable, because
 this may unset the variable in a parent [[rt_data]] object (via linked
 var lists).
 <<RT data: rt data: TBP>>=
   procedure :: unselect_model => rt_data_unselect_model
 <<RT data: procedures>>=
   subroutine rt_data_unselect_model (global)
     class(rt_data_t), intent(inout), target :: global
     if (associated (global%model)) then
        global%model => null ()
        global%model_is_copy = .false.
     end if
   end subroutine rt_data_unselect_model
 
 @ %def rt_data_unselect_model
 @
 Create a copy of the currently selected model and append it to the local model
 list.  The model pointer is redirected to the copy.
 (Not applicable for the global model list, those models will be
 modified in-place.)
 <<RT data: rt data: TBP>>=
   procedure :: ensure_model_copy => rt_data_ensure_model_copy
 <<RT data: procedures>>=
   subroutine rt_data_ensure_model_copy (global)
     class(rt_data_t), intent(inout), target :: global
     if (associated (global%context)) then
        if (.not. global%model_is_copy) then
           call global%model_list%append_copy (global%model, global%model)
           global%model_is_copy = .true.
           call global%model%link_var_list (global%var_list)
        end if
     end if
   end subroutine rt_data_ensure_model_copy
 
 @ %def rt_data_ensure_model_copy
 @
 Modify a model variable.  The update mechanism will ensure that the model
 parameter set remains consistent.  This has to take place in a local copy
 of the current model.  If there is none yet, create one.
 <<RT data: rt data: TBP>>=
   procedure :: model_set_real => rt_data_model_set_real
 <<RT data: procedures>>=
   subroutine rt_data_model_set_real (global, name, rval, verbose, pacified)
     class(rt_data_t), intent(inout), target :: global
     type(string_t), intent(in) :: name
     real(default), intent(in) :: rval
     logical, intent(in), optional :: verbose, pacified
     call global%ensure_model_copy ()
     call global%model%set_real (name, rval, verbose, pacified)
   end subroutine rt_data_model_set_real
 
 @ %def rt_data_model_set_real
 @
 Modify particle properties.  This has to take place in a local copy
 of the current model.  If there is none yet, create one.
 <<RT data: rt data: TBP>>=
   procedure :: modify_particle => rt_data_modify_particle
 <<RT data: procedures>>=
   subroutine rt_data_modify_particle &
        (global, pdg, polarized, stable, decay, &
        isotropic_decay, diagonal_decay, decay_helicity)
     class(rt_data_t), intent(inout), target :: global
     integer, intent(in) :: pdg
     logical, intent(in), optional :: polarized, stable
     logical, intent(in), optional :: isotropic_decay, diagonal_decay
     integer, intent(in), optional :: decay_helicity
     type(string_t), dimension(:), intent(in), optional :: decay
     call global%ensure_model_copy ()
     if (present (polarized)) then
        if (polarized) then
           call global%model%set_polarized (pdg)
        else
           call global%model%set_unpolarized (pdg)
        end if
     end if
     if (present (stable)) then
        if (stable) then
           call global%model%set_stable (pdg)
        else if (present (decay)) then
           call global%model%set_unstable &
                (pdg, decay, isotropic_decay, diagonal_decay, decay_helicity)
        else
           call msg_bug ("Setting particle unstable: missing decay processes")
        end if
     end if
   end subroutine rt_data_modify_particle
 
 @ %def rt_data_modify_particle
 @
 \subsection{Managing Variables}
 Return a pointer to the currently active variable list.  If there is no model,
 this is the global variable list.  If there is one, it is the model variable
 list, which should be linked to the former.
 <<RT data: rt data: TBP>>=
   procedure :: get_var_list_ptr => rt_data_get_var_list_ptr
 <<RT data: procedures>>=
   function rt_data_get_var_list_ptr (global) result (var_list)
     class(rt_data_t), intent(in), target :: global
     type(var_list_t), pointer :: var_list
     if (associated (global%model)) then
        var_list => global%model%get_var_list_ptr ()
     else
        var_list => global%var_list
     end if
   end function rt_data_get_var_list_ptr
 
 @ %def rt_data_get_var_list_ptr
 @ Initialize a local variable: append it to the current variable list.  No
 initial value, yet.
 <<RT data: rt data: TBP>>=
   procedure :: append_log => rt_data_append_log
   procedure :: append_int => rt_data_append_int
   procedure :: append_real => rt_data_append_real
   procedure :: append_cmplx => rt_data_append_cmplx
   procedure :: append_subevt => rt_data_append_subevt
   procedure :: append_pdg_array => rt_data_append_pdg_array
   procedure :: append_string => rt_data_append_string
 <<RT data: procedures>>=
   subroutine rt_data_append_log (local, name, lval, intrinsic, user)
     class(rt_data_t), intent(inout) :: local
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: lval
     logical, intent(in), optional :: intrinsic, user
     call local%var_list%append_log (name, lval, &
          intrinsic = intrinsic, user = user)
   end subroutine rt_data_append_log
 
   subroutine rt_data_append_int (local, name, ival, intrinsic, user)
     class(rt_data_t), intent(inout) :: local
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: ival
     logical, intent(in), optional :: intrinsic, user
     call local%var_list%append_int (name, ival, &
          intrinsic = intrinsic, user = user)
   end subroutine rt_data_append_int
 
   subroutine rt_data_append_real (local, name, rval, intrinsic, user)
     class(rt_data_t), intent(inout) :: local
     type(string_t), intent(in) :: name
     real(default), intent(in), optional :: rval
     logical, intent(in), optional :: intrinsic, user
     call local%var_list%append_real (name, rval, &
          intrinsic = intrinsic, user = user)
   end subroutine rt_data_append_real
 
   subroutine rt_data_append_cmplx (local, name, cval, intrinsic, user)
     class(rt_data_t), intent(inout) :: local
     type(string_t), intent(in) :: name
     complex(default), intent(in), optional :: cval
     logical, intent(in), optional :: intrinsic, user
     call local%var_list%append_cmplx (name, cval, &
          intrinsic = intrinsic, user = user)
   end subroutine rt_data_append_cmplx
 
   subroutine rt_data_append_subevt (local, name, pval, intrinsic, user)
     class(rt_data_t), intent(inout) :: local
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), optional :: pval
     logical, intent(in) :: intrinsic, user
     call local%var_list%append_subevt (name, &
          intrinsic = intrinsic, user = user)
   end subroutine rt_data_append_subevt
 
   subroutine rt_data_append_pdg_array (local, name, aval, intrinsic, user)
     class(rt_data_t), intent(inout) :: local
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), optional :: aval
     logical, intent(in), optional :: intrinsic, user
     call local%var_list%append_pdg_array (name, aval, &
          intrinsic = intrinsic, user = user)
   end subroutine rt_data_append_pdg_array
 
   subroutine rt_data_append_string (local, name, sval, intrinsic, user)
     class(rt_data_t), intent(inout) :: local
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: sval
     logical, intent(in), optional :: intrinsic, user
     call local%var_list%append_string (name, sval, &
          intrinsic = intrinsic, user = user)
   end subroutine rt_data_append_string
 
 @ %def rt_data_append_log
 @ %def rt_data_append_int
 @ %def rt_data_append_real
 @ %def rt_data_append_cmplx
 @ %def rt_data_append_subevt
 @ %def rt_data_append_pdg_array
 @ %def rt_data_append_string
 @ Import values for all local variables, given a global context environment
 where these variables are defined.
 <<RT data: rt data: TBP>>=
   procedure :: import_values => rt_data_import_values
 <<RT data: procedures>>=
   subroutine rt_data_import_values (local)
     class(rt_data_t), intent(inout) :: local
     type(rt_data_t), pointer :: global
     global => local%context
     if (associated (global)) then
        call local%var_list%import (global%var_list)
     end if
   end subroutine rt_data_import_values
 
 @ %def rt_data_import_values
 @ Unset all variable values.
 <<RT data: rt data: TBP>>=
   procedure :: unset_values => rt_data_unset_values
 <<RT data: procedures>>=
   subroutine rt_data_unset_values (global)
     class(rt_data_t), intent(inout) :: global
     call global%var_list%undefine (follow_link=.false.)
   end subroutine rt_data_unset_values
 
 @ %def rt_data_unset_values
 @ Set a variable.  (Not a model variable, these are handled separately.)  We
 can assume that the variable has been initialized.
 <<RT data: rt data: TBP>>=
   procedure :: set_log => rt_data_set_log
   procedure :: set_int => rt_data_set_int
   procedure :: set_real => rt_data_set_real
   procedure :: set_cmplx => rt_data_set_cmplx
   procedure :: set_subevt => rt_data_set_subevt
   procedure :: set_pdg_array => rt_data_set_pdg_array
   procedure :: set_string => rt_data_set_string
 <<RT data: procedures>>=
   subroutine rt_data_set_log &
        (global, name, lval, is_known, force, verbose)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     logical, intent(in) :: lval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: force, verbose
     call global%var_list%set_log (name, lval, is_known, &
          force=force, verbose=verbose)
   end subroutine rt_data_set_log
 
   subroutine rt_data_set_int &
        (global, name, ival, is_known, force, verbose)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     integer, intent(in) :: ival
     logical, intent(in) :: is_known
     logical, intent(in), optional :: force, verbose
     call global%var_list%set_int (name, ival, is_known, &
          force=force, verbose=verbose)
   end subroutine rt_data_set_int
 
   subroutine rt_data_set_real &
        (global, name, rval, is_known, force, verbose, pacified)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     real(default), intent(in) :: rval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: force, verbose, pacified
     call global%var_list%set_real (name, rval, is_known, &
          force=force, verbose=verbose, pacified=pacified)
   end subroutine rt_data_set_real
 
   subroutine rt_data_set_cmplx &
        (global, name, cval, is_known, force, verbose, pacified)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     complex(default), intent(in) :: cval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: force, verbose, pacified
     call global%var_list%set_cmplx (name, cval, is_known, &
          force=force, verbose=verbose, pacified=pacified)
   end subroutine rt_data_set_cmplx
 
   subroutine rt_data_set_subevt &
        (global, name, pval, is_known, force, verbose)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in) :: pval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: force, verbose
     call global%var_list%set_subevt (name, pval, is_known, &
          force=force, verbose=verbose)
   end subroutine rt_data_set_subevt
 
   subroutine rt_data_set_pdg_array &
        (global, name, aval, is_known, force, verbose)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in) :: aval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: force, verbose
     call global%var_list%set_pdg_array (name, aval, is_known, &
          force=force, verbose=verbose)
   end subroutine rt_data_set_pdg_array
 
   subroutine rt_data_set_string &
        (global, name, sval, is_known, force, verbose)
     class(rt_data_t), intent(inout) :: global
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: sval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: force, verbose
     call global%var_list%set_string (name, sval, is_known, &
          force=force, verbose=verbose)
   end subroutine rt_data_set_string
 
 @ %def rt_data_set_log
 @ %def rt_data_set_int
 @ %def rt_data_set_real
 @ %def rt_data_set_cmplx
 @ %def rt_data_set_subevt
 @ %def rt_data_set_pdg_array
 @ %def rt_data_set_string
 @ Return the value of a variable, assuming that the type is correct.
 <<RT data: rt data: TBP>>=
   procedure :: get_lval => rt_data_get_lval
   procedure :: get_ival => rt_data_get_ival
   procedure :: get_rval => rt_data_get_rval
   procedure :: get_cval => rt_data_get_cval
   procedure :: get_pval => rt_data_get_pval
   procedure :: get_aval => rt_data_get_aval
   procedure :: get_sval => rt_data_get_sval
 <<RT data: procedures>>=
   function rt_data_get_lval (global, name) result (lval)
     logical :: lval
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     lval = var_list%get_lval (name)
   end function rt_data_get_lval
 
   function rt_data_get_ival (global, name) result (ival)
     integer :: ival
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     ival = var_list%get_ival (name)
   end function rt_data_get_ival
 
   function rt_data_get_rval (global, name) result (rval)
     real(default) :: rval
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     rval = var_list%get_rval (name)
   end function rt_data_get_rval
 
   function rt_data_get_cval (global, name) result (cval)
     complex(default) :: cval
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     cval = var_list%get_cval (name)
   end function rt_data_get_cval
 
   function rt_data_get_aval (global, name) result (aval)
     type(pdg_array_t) :: aval
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     aval = var_list%get_aval (name)
   end function rt_data_get_aval
 
   function rt_data_get_pval (global, name) result (pval)
     type(subevt_t) :: pval
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     pval = var_list%get_pval (name)
   end function rt_data_get_pval
 
   function rt_data_get_sval (global, name) result (sval)
     type(string_t) :: sval
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     sval = var_list%get_sval (name)
   end function rt_data_get_sval
 
 @ %def rt_data_get_lval
 @ %def rt_data_get_ival
 @ %def rt_data_get_rval
 @ %def rt_data_get_cval
 @ %def rt_data_get_pval
 @ %def rt_data_get_aval
 @ %def rt_data_get_sval
 @ Return true if the variable exists in the global list.
 <<RT data: rt data: TBP>>=
   procedure :: contains => rt_data_contains
 <<RT data: procedures>>=
   function rt_data_contains (global, name) result (lval)
     logical :: lval
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     lval = var_list%contains (name)
   end function rt_data_contains
 
 @ %def rt_data_contains
 @ Return true if the value of the variable is known.
 <<RT data: rt data: TBP>>=
   procedure :: is_known => rt_data_is_known
 <<RT data: procedures>>=
   function rt_data_is_known (global, name) result (lval)
     logical :: lval
     class(rt_data_t), intent(in), target :: global
     type(string_t), intent(in) :: name
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     lval = var_list%is_known (name)
   end function rt_data_is_known
 
 @ %def rt_data_is_known
 @
 \subsection{Further Content}
 Add a library (available via a pointer of type [[prclib_entry_t]]) to
 the stack and update the pointer and variable list to the current
 library.  The pointer association of [[prclib_entry]] will be discarded.
 <<RT data: rt data: TBP>>=
   procedure :: add_prclib => rt_data_add_prclib
 <<RT data: procedures>>=
   subroutine rt_data_add_prclib (global, prclib_entry)
     class(rt_data_t), intent(inout) :: global
     type(prclib_entry_t), intent(inout), pointer :: prclib_entry
     call global%prclib_stack%push (prclib_entry)
     call global%update_prclib (global%prclib_stack%get_first_ptr ())
   end subroutine rt_data_add_prclib
 
 @ %def rt_data_add_prclib
 @ Given a pointer to a process library, make this the currently active
 library.
 <<RT data: rt data: TBP>>=
   procedure :: update_prclib => rt_data_update_prclib
 <<RT data: procedures>>=
   subroutine rt_data_update_prclib (global, lib)
     class(rt_data_t), intent(inout) :: global
     type(process_library_t), intent(in), target :: lib
     global%prclib => lib
     if (global%var_list%contains (&
          var_str ("$library_name"), follow_link = .false.)) then
        call global%var_list%set_string (var_str ("$library_name"), &
             global%prclib%get_name (), is_known=.true.)
     else
        call global%var_list%append_string ( &
             var_str ("$library_name"), global%prclib%get_name (), &
             intrinsic = .true.)
     end if
   end subroutine rt_data_update_prclib
 
 @ %def rt_data_update_prclib
 @
 \subsection{Miscellaneous}
 The helicity selection data are distributed among several parameters.  Here,
 we collect them in a single record.
 <<RT data: rt data: TBP>>=
   procedure :: get_helicity_selection => rt_data_get_helicity_selection
 <<RT data: procedures>>=
   function rt_data_get_helicity_selection (rt_data) result (helicity_selection)
     class(rt_data_t), intent(in) :: rt_data
     type(helicity_selection_t) :: helicity_selection
     associate (var_list => rt_data%var_list)
       helicity_selection%active = var_list%get_lval (&
            var_str ("?helicity_selection_active"))
       if (helicity_selection%active) then
          helicity_selection%threshold = var_list%get_rval (&
               var_str ("helicity_selection_threshold"))
          helicity_selection%cutoff = var_list%get_ival (&
               var_str ("helicity_selection_cutoff"))
       end if
     end associate
   end function rt_data_get_helicity_selection
 
 @ %def rt_data_get_helicity_selection
 @ Show the beam setup: beam structure and relevant global variables.
 <<RT data: rt data: TBP>>=
   procedure :: show_beams => rt_data_show_beams
 <<RT data: procedures>>=
   subroutine rt_data_show_beams (rt_data, unit)
     class(rt_data_t), intent(in) :: rt_data
     integer, intent(in), optional :: unit
     type(string_t) :: s
     integer :: u
     u = given_output_unit (unit)
     associate (beams => rt_data%beam_structure, var_list => rt_data%var_list)
       call beams%write (u)
       if (.not. beams%asymmetric () .and. beams%get_n_beam () == 2) then
          write (u, "(2x,A," // FMT_19 // ",1x,'GeV')") "sqrts =", &
               var_list%get_rval (var_str ("sqrts"))
       end if
       if (beams%contains ("pdf_builtin")) then
          s = var_list%get_sval (var_str ("$pdf_builtin_set"))
          if (s /= "") then
             write (u, "(2x,A,1x,3A)")  "PDF set =", '"', char (s), '"'
          else
             write (u, "(2x,A,1x,A)")  "PDF set =", "[undefined]"
          end if
       end if
       if (beams%contains ("lhapdf")) then
          s = var_list%get_sval (var_str ("$lhapdf_dir"))
          if (s /= "") then
             write (u, "(2x,A,1x,3A)")  "LHAPDF dir    =", '"', char (s), '"'
          end if
          s = var_list%get_sval (var_str ("$lhapdf_file"))
          if (s /= "") then
             write (u, "(2x,A,1x,3A)")  "LHAPDF file   =", '"', char (s), '"'
             write (u, "(2x,A,1x,I0)") "LHAPDF member =", &
                  var_list%get_ival (var_str ("lhapdf_member"))
          else
             write (u, "(2x,A,1x,A)")  "LHAPDF file   =", "[undefined]"
          end if
       end if
       if (beams%contains ("lhapdf_photon")) then
          s = var_list%get_sval (var_str ("$lhapdf_dir"))
          if (s /= "") then
             write (u, "(2x,A,1x,3A)")  "LHAPDF dir    =", '"', char (s), '"'
          end if
          s = var_list%get_sval (var_str ("$lhapdf_photon_file"))
          if (s /= "") then
             write (u, "(2x,A,1x,3A)")  "LHAPDF file   =", '"', char (s), '"'
             write (u, "(2x,A,1x,I0)") "LHAPDF member =", &
                  var_list%get_ival (var_str ("lhapdf_member"))
             write (u, "(2x,A,1x,I0)") "LHAPDF scheme =", &
                  var_list%get_ival (&
                  var_str ("lhapdf_photon_scheme"))
          else
             write (u, "(2x,A,1x,A)")  "LHAPDF file   =", "[undefined]"
          end if
       end if
       if (beams%contains ("isr")) then
          write (u, "(2x,A," // FMT_19 // ")") "ISR alpha        =", &
               var_list%get_rval (var_str ("isr_alpha"))
          write (u, "(2x,A," // FMT_19 // ")") "ISR Q max        =", &
               var_list%get_rval (var_str ("isr_q_max"))
          write (u, "(2x,A," // FMT_19 // ")") "ISR mass         =", &
               var_list%get_rval (var_str ("isr_mass"))
          write (u, "(2x,A,1x,I0)") "ISR order        =", &
               var_list%get_ival (var_str ("isr_order"))
          write (u, "(2x,A,1x,L1)") "ISR recoil       =", &
               var_list%get_lval (var_str ("?isr_recoil"))
          write (u, "(2x,A,1x,L1)") "ISR energy cons. =", &
               var_list%get_lval (var_str ("?isr_keep_energy"))
       end if
       if (beams%contains ("epa")) then
          write (u, "(2x,A," // FMT_19 // ")") "EPA alpha         =", &
               var_list%get_rval (var_str ("epa_alpha"))
          write (u, "(2x,A," // FMT_19 // ")") "EPA x min         =", &
               var_list%get_rval (var_str ("epa_x_min"))
          write (u, "(2x,A," // FMT_19 // ")") "EPA Q min         =", &
               var_list%get_rval (var_str ("epa_q_min"))
          write (u, "(2x,A," // FMT_19 // ")") "EPA Q max         =", &
               var_list%get_rval (var_str ("epa_q_max"))
          write (u, "(2x,A," // FMT_19 // ")") "EPA mass          =", &
               var_list%get_rval (var_str ("epa_mass"))
          write (u, "(2x,A,1x,L1)") "EPA recoil        =", &
               var_list%get_lval (var_str ("?epa_recoil"))
          write (u, "(2x,A,1x,L1)") "EPA  energy cons. =", &
               var_list%get_lval (var_str ("?epa_keep_energy"))
       end if
       if (beams%contains ("ewa")) then
          write (u, "(2x,A," // FMT_19 // ")") "EWA x min       =", &
               var_list%get_rval (var_str ("ewa_x_min"))
          write (u, "(2x,A," // FMT_19 // ")") "EWA Pt max      =", &
               var_list%get_rval (var_str ("ewa_pt_max"))
          write (u, "(2x,A," // FMT_19 // ")") "EWA mass        =", &
               var_list%get_rval (var_str ("ewa_mass"))
          write (u, "(2x,A,1x,L1)") "EWA recoil       =", &
               var_list%get_lval (var_str ("?ewa_recoil"))
          write (u, "(2x,A,1x,L1)") "EWA energy cons. =", &
               var_list%get_lval (var_str ("ewa_keep_energy"))
       end if
       if (beams%contains ("circe1")) then
          write (u, "(2x,A,1x,I0)") "CIRCE1 version    =", &
               var_list%get_ival (var_str ("circe1_ver"))
          write (u, "(2x,A,1x,I0)") "CIRCE1 revision   =", &
               var_list%get_ival (var_str ("circe1_rev"))
          s = var_list%get_sval (var_str ("$circe1_acc"))
          write (u, "(2x,A,1x,A)") "CIRCE1 acceler.   =", char (s)
          write (u, "(2x,A,1x,I0)") "CIRCE1 chattin.   =", &
               var_list%get_ival (var_str ("circe1_chat"))
          write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 sqrts      =", &
               var_list%get_rval (var_str ("circe1_sqrts"))
          write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 epsil.     =", &
               var_list%get_rval (var_str ("circe1_eps"))
          write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 1  =", &
               var_list%get_lval (var_str ("?circe1_photon1"))
          write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 2  =", &
               var_list%get_lval (var_str ("?circe1_photon2"))
          write (u, "(2x,A,1x,L1)") "CIRCE1 generat. =", &
               var_list%get_lval (var_str ("?circe1_generate"))
          write (u, "(2x,A,1x,L1)") "CIRCE1 mapping  =", &
               var_list%get_lval (var_str ("?circe1_map"))
          write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 map. slope =", &
               var_list%get_rval (var_str ("circe1_mapping_slope"))
          write (u, "(2x,A,1x,L1)") "CIRCE recoil photon =", &
               var_list%get_lval (var_str ("?circe1_with_radiation"))
       end if
       if (beams%contains ("circe2")) then
          s = var_list%get_sval (var_str ("$circe2_design"))
          write (u, "(2x,A,1x,A)") "CIRCE2 design   =", char (s)
          s = var_list%get_sval (var_str ("$circe2_file"))
          write (u, "(2x,A,1x,A)") "CIRCE2 file     =", char (s)
          write (u, "(2x,A,1x,L1)") "CIRCE2 polarized =", &
               var_list%get_lval (var_str ("?circe2_polarized"))
       end if
       if (beams%contains ("gaussian")) then
          write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 1    =", &
               var_list%get_rval (var_str ("gaussian_spread1"))
          write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 2    =", &
               var_list%get_rval (var_str ("gaussian_spread2"))
       end if
       if (beams%contains ("beam_events")) then
          s = var_list%get_sval (var_str ("$beam_events_file"))
          write (u, "(2x,A,1x,A)") "Beam events file     =", char (s)
          write (u, "(2x,A,1x,L1)") "Beam events EOF warn =", &
               var_list%get_lval (var_str ("?beam_events_warn_eof"))
       end if
     end associate
   end subroutine rt_data_show_beams
 
 @ %def rt_data_show_beams
 @ Return the collision energy as determined by the current beam
 settings.  Without beam setup, this is the [[sqrts]] variable.
 
 If the value is meaningless for a setup, the function returns zero.
 <<RT data: rt data: TBP>>=
   procedure :: get_sqrts => rt_data_get_sqrts
 <<RT data: procedures>>=
   function rt_data_get_sqrts (rt_data) result (sqrts)
     class(rt_data_t), intent(in) :: rt_data
     real(default) :: sqrts
     sqrts = rt_data%var_list%get_rval (var_str ("sqrts"))
   end function rt_data_get_sqrts
 
 @ %def rt_data_get_sqrts
 @ For testing purposes, the [[rt_data_t]] contents can be pacified to
 suppress numerical fluctuations in (constant) test matrix elements.
 <<RT data: rt data: TBP>>=
   procedure :: pacify => rt_data_pacify
 <<RT data: procedures>>=
   subroutine rt_data_pacify (rt_data, efficiency_reset, error_reset)
     class(rt_data_t), intent(inout) :: rt_data
     logical, intent(in), optional :: efficiency_reset, error_reset
     type(process_entry_t), pointer :: process
     process => rt_data%process_stack%first
     do while (associated (process))
        call process%pacify (efficiency_reset, error_reset)
        process => process%next
     end do
   end subroutine rt_data_pacify
 
 @ %def rt_data_pacify
 @
 <<RT data: rt data: TBP>>=
   procedure :: set_event_callback => rt_data_set_event_callback
 <<RT data: procedures>>=
   subroutine rt_data_set_event_callback (global, callback)
     class(rt_data_t), intent(inout) :: global
     class(event_callback_t), intent(in) :: callback
     if (allocated (global%event_callback))  deallocate (global%event_callback)
     allocate (global%event_callback, source = callback)
   end subroutine rt_data_set_event_callback
 
 @ %def rt_data_set_event_callback
 @
 <<RT data: rt data: TBP>>=
   procedure :: has_event_callback => rt_data_has_event_callback
   procedure :: get_event_callback => rt_data_get_event_callback
 <<RT data: procedures>>=
   function rt_data_has_event_callback (global) result (flag)
     class(rt_data_t), intent(in) :: global
     logical :: flag
     flag = allocated (global%event_callback)
   end function rt_data_has_event_callback
 
   function rt_data_get_event_callback (global) result (callback)
     class(rt_data_t), intent(in) :: global
     class(event_callback_t), allocatable :: callback
     if (allocated (global%event_callback)) then
        allocate (callback, source = global%event_callback)
     end if
   end function rt_data_get_event_callback
 
 @ %def rt_data_has_event_callback
 @ %def rt_data_get_event_callback
 @ Force system-dependent objects to well-defined values.  Some of the
 variables are locked and therefore must be addressed directly.
 
 This is, of course, only required for testing purposes. In principle,
 the [[real_specimen]] variables could be set to their values in
 [[rt_data_t]], but this depends on the precision again, so we set
 them to some dummy values.
 <<RT data: public>>=
   public :: fix_system_dependencies
 <<RT data: procedures>>=
   subroutine fix_system_dependencies (global)
     class(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
 
     var_list => global%get_var_list_ptr ()
     call var_list%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true., force=.true.)
     call var_list%set_log (var_str ("?openmp_is_active"), &
          .false., is_known = .true., force=.true.)
     call var_list%set_int (var_str ("openmp_num_threads_default"), &
          1, is_known = .true., force=.true.)
     call var_list%set_int (var_str ("openmp_num_threads"), &
          1, is_known = .true., force=.true.)
     call var_list%set_int (var_str ("real_range"), &
          307, is_known = .true., force=.true.)
     call var_list%set_int (var_str ("real_precision"), &
          15, is_known = .true., force=.true.)
     call var_list%set_real (var_str ("real_epsilon"), &
          1.e-16_default, is_known = .true., force=.true.)
     call var_list%set_real (var_str ("real_tiny"), &
          1.e-300_default, is_known = .true., force=.true.)
 
     global%os_data%fc = "Fortran-compiler"
     global%os_data%fcflags = "Fortran-flags"
 
   end subroutine fix_system_dependencies
 
 @ %def fix_system_dependencies
 @
 <<RT data: public>>=
   public :: show_description_of_string
 <<RT data: procedures>>=
   subroutine show_description_of_string (string)
     type(string_t), intent(in) :: string
     type(rt_data_t), target :: global
     call global%global_init ()
     call global%show_description_of_string (string, ascii_output=.true.)
   end subroutine show_description_of_string
 
 @ %def show_description_of_string
 @
 <<RT data: public>>=
   public :: show_tex_descriptions
 <<RT data: procedures>>=
   subroutine show_tex_descriptions ()
     type(rt_data_t), target :: global
     call global%global_init ()
     call fix_system_dependencies (global)
     call global%set_int (var_str ("seed"), 0, is_known=.true.)
     call global%var_list%sort ()
     call global%write_var_descriptions ()
   end subroutine show_tex_descriptions
 
 @ %def show_tex_descriptions
 @
 \subsection{Unit Tests}
 Test module, followed by the corresponding implementation module.
 <<[[rt_data_ut.f90]]>>=
 <<File header>>
 
 module rt_data_ut
   use unit_tests
   use rt_data_uti
 
 <<Standard module head>>
 
 <<RT data: public test>>
 
 contains
 
 <<RT data: test driver>>
 
 end module rt_data_ut
 @ %def rt_data_ut
 @
 <<[[rt_data_uti.f90]]>>=
 <<File header>>
 
 module rt_data_uti
 
 <<Use kinds>>
 <<Use strings>>
   use format_defs, only: FMT_19
   use ifiles
   use lexers
   use parser
   use flavors
   use variables, only: var_list_t, var_entry_t, var_entry_init_int
   use eval_trees
   use models
   use prclib_stacks
 
   use rt_data
 
 <<Standard module head>>
 
 <<RT data: test declarations>>
 
 contains
 
 <<RT data: test auxiliary>>
 
 <<RT data: tests>>
 
 end module rt_data_uti
 @ %def rt_data_ut
 @ API: driver for the unit tests below.
 <<RT data: public test>>=
   public :: rt_data_test
 <<RT data: test driver>>=
   subroutine rt_data_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<RT data: execute tests>>
   end subroutine rt_data_test
 
 @ %def rt_data_test
 @
 \subsubsection{Initial content}
 @
 Display the RT data in the state just after (global) initialization.
 <<RT data: execute tests>>=
   call test (rt_data_1, "rt_data_1", &
        "initialize", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_1
 <<RT data: tests>>=
   subroutine rt_data_1 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: rt_data_1"
     write (u, "(A)")  "*   Purpose: initialize global runtime data"
     write (u, "(A)")
 
     call global%global_init (logfile = var_str ("rt_data.log"))
     call fix_system_dependencies (global)
 
     call global%set_int (var_str ("seed"), 0, is_known=.true.)
 
     call global%it_list%init ([2, 3], [5000, 20000])
 
     call global%write (u)
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_1"
 
   end subroutine rt_data_1
 
 @ %def rt_data_1
 @
 \subsubsection{Fill values}
 Fill in empty slots in the runtime data block.
 <<RT data: execute tests>>=
   call test (rt_data_2, "rt_data_2", &
        "fill", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_2
 <<RT data: tests>>=
   subroutine rt_data_2 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     type(flavor_t), dimension(2) :: flv
     type(string_t) :: cut_expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: parse_tree
 
     write (u, "(A)")  "* Test output: rt_data_2"
     write (u, "(A)")  "*   Purpose: initialize global runtime data &
          &and fill contents"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call fix_system_dependencies (global)
 
     call global%select_model (var_str ("Test"))
 
     call global%set_real (var_str ("sqrts"), &
          1000._default, is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
     call flv%init ([25,25], global%model)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("run1"), is_known = .true.)
     call global%set_real (var_str ("luminosity"), &
          33._default, is_known = .true.)
 
     call syntax_pexpr_init ()
     cut_expr_text = "all Pt > 100 [s]"
     call ifile_append (ifile, cut_expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (parse_tree, stream, .true.)
     global%pn%cuts_lexpr => parse_tree%get_root_ptr ()
 
     allocate (global%sample_fmt (2))
     global%sample_fmt(1) = "foo_fmt"
     global%sample_fmt(2) = "bar_fmt"
 
     call global%write (u)
 
     call parse_tree_final (parse_tree)
     call stream_final (stream)
     call ifile_final (ifile)
     call syntax_pexpr_final ()
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_2"
 
   end subroutine rt_data_2
 
 @ %def rt_data_2
 @
 \subsubsection{Save and restore}
 Set up a local runtime data block, change some contents, restore the
 global block.
 <<RT data: execute tests>>=
   call test (rt_data_3, "rt_data_3", &
        "save/restore", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_3
 <<RT data: tests>>=
   subroutine rt_data_3 (u)
     use event_base, only: event_callback_nop_t
     integer, intent(in) :: u
     type(rt_data_t), target :: global, local
     type(flavor_t), dimension(2) :: flv
     type(string_t) :: cut_expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: parse_tree
     type(prclib_entry_t), pointer :: lib
     type(event_callback_nop_t) :: event_callback_nop
 
     write (u, "(A)")  "* Test output: rt_data_3"
     write (u, "(A)")  "*   Purpose: initialize global runtime data &
          &and fill contents;"
     write (u, "(A)")  "*            copy to local block and back"
     write (u, "(A)")
 
     write (u, "(A)")  "* Init global data"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call fix_system_dependencies (global)
 
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%select_model (var_str ("Test"))
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call flv%init ([25,25], global%model)
 
     call global%beam_structure%init_sf (flv%get_name (), [1])
     call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin"))
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("run1"), is_known = .true.)
     call global%set_real (var_str ("luminosity"), &
          33._default, is_known = .true.)
 
     call syntax_pexpr_init ()
     cut_expr_text = "all Pt > 100 [s]"
     call ifile_append (ifile, cut_expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (parse_tree, stream, .true.)
     global%pn%cuts_lexpr => parse_tree%get_root_ptr ()
 
     allocate (global%sample_fmt (2))
     global%sample_fmt(1) = "foo_fmt"
     global%sample_fmt(2) = "bar_fmt"
 
     allocate (lib)
     call lib%init (var_str ("library_1"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "* Init and modify local data"
     write (u, "(A)")
 
     call local%local_init (global)
     call local%append_string (var_str ("$integration_method"), intrinsic=.true.)
     call local%append_string (var_str ("$phs_method"), intrinsic=.true.)
 
     call local%activate ()
 
     write (u, "(1x,A,L1)")  "model associated   = ", associated (local%model)
     write (u, "(1x,A,L1)")  "library associated = ", associated (local%prclib)
     write (u, *)
 
     call local%model_set_real (var_str ("ms"), 150._default)
     call local%set_string (var_str ("$integration_method"), &
          var_str ("midpoint"), is_known = .true.)
     call local%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
 
     local%os_data%fc = "Local compiler"
 
     allocate (lib)
     call lib%init (var_str ("library_2"))
     call local%add_prclib (lib)
 
     call local%set_event_callback (event_callback_nop)
 
     call local%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Restore global data"
     write (u, "(A)")
 
     call local%deactivate (global)
 
     write (u, "(1x,A,L1)")  "model associated   = ", associated (global%model)
     write (u, "(1x,A,L1)")  "library associated = ", associated (global%prclib)
     write (u, *)
 
     call global%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call parse_tree_final (parse_tree)
     call stream_final (stream)
     call ifile_final (ifile)
     call syntax_pexpr_final ()
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_3"
 
   end subroutine rt_data_3
 
 @ %def rt_data_3
 @
 \subsubsection{Show variables}
 Display selected variables in the global record.
 <<RT data: execute tests>>=
   call test (rt_data_4, "rt_data_4", &
        "show variables", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_4
 <<RT data: tests>>=
   subroutine rt_data_4 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
 
     type(string_t), dimension(0) :: empty_string_array
 
     write (u, "(A)")  "* Test output: rt_data_4"
     write (u, "(A)")  "*   Purpose: display selected variables"
     write (u, "(A)")
 
     call global%global_init ()
 
     write (u, "(A)")  "* No variables:"
     write (u, "(A)")
 
     call global%write_vars (u, empty_string_array)
 
     write (u, "(A)")  "* Two variables:"
     write (u, "(A)")
 
     call global%write_vars (u, &
          [var_str ("?unweighted"), var_str ("$phs_method")])
 
     write (u, "(A)")
     write (u, "(A)")  "* Display whole record with selected variables"
     write (u, "(A)")
 
     call global%write (u, &
          vars = [var_str ("?unweighted"), var_str ("$phs_method")])
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_4"
 
   end subroutine rt_data_4
 
 @ %def rt_data_4
 @
 \subsubsection{Show parts}
 Display only selected parts in the state just after (global) initialization.
 <<RT data: execute tests>>=
   call test (rt_data_5, "rt_data_5", &
        "show parts", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_5
 <<RT data: tests>>=
   subroutine rt_data_5 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: rt_data_5"
     write (u, "(A)")  "*   Purpose: display parts of rt data"
     write (u, "(A)")
 
     call global%global_init ()
     call global%write_libraries (u)
 
     write (u, "(A)")
 
     call global%write_beams (u)
 
     write (u, "(A)")
 
     call global%write_process_stack (u)
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_5"
 
   end subroutine rt_data_5
 
 @ %def rt_data_5
 @
 \subsubsection{Local Model}
 Locally modify a model and restore the global one.  We need an auxiliary
 function to determine the status of a model particle:
 <<RT data: test auxiliary>>=
   function is_stable (pdg, global) result (flag)
     integer, intent(in) :: pdg
     type(rt_data_t), intent(in) :: global
     logical :: flag
     type(flavor_t) :: flv
     call flv%init (pdg, global%model)
     flag = flv%is_stable ()
   end function is_stable
 
   function is_polarized (pdg, global) result (flag)
     integer, intent(in) :: pdg
     type(rt_data_t), intent(in) :: global
     logical :: flag
     type(flavor_t) :: flv
     call flv%init (pdg, global%model)
     flag = flv%is_polarized ()
   end function is_polarized
 
 @ %def is_stable is_polarized
 <<RT data: execute tests>>=
   call test (rt_data_6, "rt_data_6", &
        "local model", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_6
 <<RT data: tests>>=
   subroutine rt_data_6 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global, local
     type(var_list_t), pointer :: model_vars
     type(string_t) :: var_name
 
     write (u, "(A)")  "* Test output: rt_data_6"
     write (u, "(A)")  "*   Purpose: apply and keep local modifications to model"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%select_model (var_str ("Test"))
 
     write (u, "(A)")  "* Original model"
     write (u, "(A)")
 
     call global%write_model_list (u)
     write (u, *)
     write (u, "(A,L1)")  "s is stable    = ", is_stable (25, global)
     write (u, "(A,L1)")  "f is polarized = ", is_polarized (6, global)
 
     write (u, *)
 
     var_name = "ff"
 
     write (u, "(A)", advance="no")  "Global model variable: "
     model_vars => global%model%get_var_list_ptr ()
     call model_vars%write_var (var_name, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Apply local modifications: unstable"
     write (u, "(A)")
 
     call local%local_init (global)
     call local%activate ()
 
     call local%model_set_real (var_name, 0.4_default)
     call local%modify_particle (25, stable = .false., decay = [var_str ("d1")])
     call local%modify_particle (6, stable = .false., &
          decay = [var_str ("f1")], isotropic_decay = .true.)
     call local%modify_particle (-6, stable = .false., &
          decay = [var_str ("f2"), var_str ("f3")], diagonal_decay = .true.)
 
     call local%model%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Further modifications"
     write (u, "(A)")
 
     call local%modify_particle (6, stable = .false., &
          decay = [var_str ("f1")], &
          diagonal_decay = .true., isotropic_decay = .false.)
     call local%modify_particle (-6, stable = .false., &
          decay = [var_str ("f2"), var_str ("f3")], &
          diagonal_decay = .false., isotropic_decay = .true.)
     call local%model%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Further modifications: f stable but polarized"
     write (u, "(A)")
 
     call local%modify_particle (6, stable = .true., polarized = .true.)
     call local%modify_particle (-6, stable = .true.)
     call local%model%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Global model"
     write (u, "(A)")
 
     call global%model%write (u)
     write (u, *)
     write (u, "(A,L1)")  "s is stable    = ", is_stable (25, global)
     write (u, "(A,L1)")  "f is polarized = ", is_polarized (6, global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Local model"
     write (u, "(A)")
 
     call local%model%write (u)
     write (u, *)
     write (u, "(A,L1)")  "s is stable    = ", is_stable (25, local)
     write (u, "(A,L1)")  "f is polarized = ", is_polarized (6, local)
 
     write (u, *)
 
     write (u, "(A)", advance="no")  "Global model variable: "
     model_vars => global%model%get_var_list_ptr ()
     call model_vars%write_var (var_name, u)
 
     write (u, "(A)", advance="no")  "Local model variable: "
     associate (model_var_list_ptr => local%model%get_var_list_ptr())
        call model_var_list_ptr%write_var (var_name, u)
     end associate
 
     write (u, "(A)")
     write (u, "(A)")  "* Restore global"
 
     call local%deactivate (global, keep_local = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Global model"
     write (u, "(A)")
 
     call global%model%write (u)
     write (u, *)
     write (u, "(A,L1)")  "s is stable    = ", is_stable (25, global)
     write (u, "(A,L1)")  "f is polarized = ", is_polarized (6, global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Local model"
     write (u, "(A)")
 
     call local%model%write (u)
     write (u, *)
     write (u, "(A,L1)")  "s is stable    = ", is_stable (25, local)
     write (u, "(A,L1)")  "f is polarized = ", is_polarized (6, local)
 
     write (u, *)
 
     write (u, "(A)", advance="no")  "Global model variable: "
     model_vars => global%model%get_var_list_ptr ()
     call model_vars%write_var (var_name, u)
 
     write (u, "(A)", advance="no")  "Local model variable: "
     associate (model_var_list_ptr => local%model%get_var_list_ptr())
        call model_var_list_ptr%write_var (var_name, u)
     end associate
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call local%model%final ()
     deallocate (local%model)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_6"
 
   end subroutine rt_data_6
 
 @ %def rt_data_6
 @
 \subsubsection{Result variables}
 Initialize result variables and check that they are accessible via the
 global variable list.
 <<RT data: execute tests>>=
   call test (rt_data_7, "rt_data_7", &
        "result variables", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_7
 <<RT data: tests>>=
   subroutine rt_data_7 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: rt_data_7"
     write (u, "(A)")  "*   Purpose: set and access result variables"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process variables"
     write (u, "(A)")
 
     call global%global_init ()
     call global%process_stack%init_result_vars (var_str ("testproc"))
 
     call global%var_list%write_var (&
          var_str ("integral(testproc)"), u, defined=.true.)
     call global%var_list%write_var (&
          var_str ("error(testproc)"), u, defined=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_7"
 
   end subroutine rt_data_7
 
 @ %def rt_data_7
 @
 \subsubsection{Beam energy}
 If beam parameters are set, the variable [[sqrts]] is not necessarily
 the collision energy.  The method [[get_sqrts]] fetches the correct value.
 <<RT data: execute tests>>=
   call test (rt_data_8, "rt_data_8", &
        "beam energy", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_8
 <<RT data: tests>>=
   subroutine rt_data_8 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: rt_data_8"
     write (u, "(A)")  "*   Purpose: get correct collision energy"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     call global%global_init ()
 
     write (u, "(A)")  "* Set sqrts"
     write (u, "(A)")
 
     call global%set_real (var_str ("sqrts"), &
          1000._default, is_known = .true.)
     write (u, "(1x,A," // FMT_19 // ")")  "sqrts =", global%get_sqrts ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_8"
 
   end subroutine rt_data_8
 
 @ %def rt_data_8
 @
 \subsubsection{Local variable modifications}
 <<RT data: execute tests>>=
   call test (rt_data_9, "rt_data_9", &
        "local variables", &
        u, results)
 <<RT data: test declarations>>=
   public :: rt_data_9
 <<RT data: tests>>=
   subroutine rt_data_9 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global, local
     type(var_list_t), pointer :: var_list
 
     write (u, "(A)")  "* Test output: rt_data_9"
     write (u, "(A)")  "*   Purpose: handle local variables"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     write (u, "(A)")  "* Initialize global record and set some variables"
     write (u, "(A)")
 
     call global%global_init ()
     call global%select_model (var_str ("Test"))
 
     call global%set_real (var_str ("sqrts"), 17._default, is_known = .true.)
     call global%set_real (var_str ("luminosity"), 2._default, is_known = .true.)
     call global%model_set_real (var_str ("ff"), 0.5_default)
     call global%model_set_real (var_str ("gy"), 1.2_default)
 
     var_list => global%get_var_list_ptr ()
 
     call var_list%write_var (var_str ("sqrts"), u, defined=.true.)
     call var_list%write_var (var_str ("luminosity"), u, defined=.true.)
     call var_list%write_var (var_str ("ff"), u, defined=.true.)
     call var_list%write_var (var_str ("gy"), u, defined=.true.)
     call var_list%write_var (var_str ("mf"), u, defined=.true.)
     call var_list%write_var (var_str ("x"), u, defined=.true.)
 
     write (u, "(A)")
 
     write (u, "(1x,A,1x,F5.2)")  "sqrts      = ", &
          global%get_rval (var_str ("sqrts"))
     write (u, "(1x,A,1x,F5.2)")  "luminosity = ", &
          global%get_rval (var_str ("luminosity"))
     write (u, "(1x,A,1x,F5.2)")  "ff         = ", &
          global%get_rval (var_str ("ff"))
     write (u, "(1x,A,1x,F5.2)")  "gy         = ", &
          global%get_rval (var_str ("gy"))
     write (u, "(1x,A,1x,F5.2)")  "mf         = ", &
          global%get_rval (var_str ("mf"))
     write (u, "(1x,A,1x,F5.2)")  "x          = ", &
          global%get_rval (var_str ("x"))
 
     write (u, "(A)")
     write (u, "(A)")  "* Create local record with local variables"
     write (u, "(A)")
 
     call local%local_init (global)
 
     call local%append_real (var_str ("luminosity"), intrinsic = .true.)
     call local%append_real (var_str ("x"), user = .true.)
 
     call local%activate ()
 
     var_list => local%get_var_list_ptr ()
 
     call var_list%write_var (var_str ("sqrts"), u)
     call var_list%write_var (var_str ("luminosity"), u)
     call var_list%write_var (var_str ("ff"), u)
     call var_list%write_var (var_str ("gy"), u)
     call var_list%write_var (var_str ("mf"), u)
     call var_list%write_var (var_str ("x"), u, defined=.true.)
 
     write (u, "(A)")
 
     write (u, "(1x,A,1x,F5.2)")  "sqrts      = ", &
          local%get_rval (var_str ("sqrts"))
     write (u, "(1x,A,1x,F5.2)")  "luminosity = ", &
          local%get_rval (var_str ("luminosity"))
     write (u, "(1x,A,1x,F5.2)")  "ff         = ", &
          local%get_rval (var_str ("ff"))
     write (u, "(1x,A,1x,F5.2)")  "gy         = ", &
          local%get_rval (var_str ("gy"))
     write (u, "(1x,A,1x,F5.2)")  "mf         = ", &
          local%get_rval (var_str ("mf"))
     write (u, "(1x,A,1x,F5.2)")  "x          = ", &
          local%get_rval (var_str ("x"))
 
     write (u, "(A)")
     write (u, "(A)")  "* Modify some local variables"
     write (u, "(A)")
 
     call local%set_real (var_str ("luminosity"), 42._default, is_known=.true.)
     call local%set_real (var_str ("x"), 6.66_default, is_known=.true.)
     call local%model_set_real (var_str ("ff"), 0.7_default)
 
     var_list => local%get_var_list_ptr ()
 
     call var_list%write_var (var_str ("sqrts"), u)
     call var_list%write_var (var_str ("luminosity"), u)
     call var_list%write_var (var_str ("ff"), u)
     call var_list%write_var (var_str ("gy"), u)
     call var_list%write_var (var_str ("mf"), u)
     call var_list%write_var (var_str ("x"), u, defined=.true.)
 
     write (u, "(A)")
 
     write (u, "(1x,A,1x,F5.2)")  "sqrts      = ", &
          local%get_rval (var_str ("sqrts"))
     write (u, "(1x,A,1x,F5.2)")  "luminosity = ", &
          local%get_rval (var_str ("luminosity"))
     write (u, "(1x,A,1x,F5.2)")  "ff         = ", &
          local%get_rval (var_str ("ff"))
     write (u, "(1x,A,1x,F5.2)")  "gy         = ", &
          local%get_rval (var_str ("gy"))
     write (u, "(1x,A,1x,F5.2)")  "mf         = ", &
          local%get_rval (var_str ("mf"))
     write (u, "(1x,A,1x,F5.2)")  "x          = ", &
          local%get_rval (var_str ("x"))
 
     write (u, "(A)")
     write (u, "(A)")  "* Restore globals"
     write (u, "(A)")
 
     call local%deactivate (global)
 
     var_list => global%get_var_list_ptr ()
 
     call var_list%write_var (var_str ("sqrts"), u)
     call var_list%write_var (var_str ("luminosity"), u)
     call var_list%write_var (var_str ("ff"), u)
     call var_list%write_var (var_str ("gy"), u)
     call var_list%write_var (var_str ("mf"), u)
     call var_list%write_var (var_str ("x"), u, defined=.true.)
 
     write (u, "(A)")
 
     write (u, "(1x,A,1x,F5.2)")  "sqrts      = ", &
          global%get_rval (var_str ("sqrts"))
     write (u, "(1x,A,1x,F5.2)")  "luminosity = ", &
          global%get_rval (var_str ("luminosity"))
     write (u, "(1x,A,1x,F5.2)")  "ff         = ", &
          global%get_rval (var_str ("ff"))
     write (u, "(1x,A,1x,F5.2)")  "gy         = ", &
          global%get_rval (var_str ("gy"))
     write (u, "(1x,A,1x,F5.2)")  "mf         = ", &
          global%get_rval (var_str ("mf"))
     write (u, "(1x,A,1x,F5.2)")  "x          = ", &
          global%get_rval (var_str ("x"))
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call local%local_final ()
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_9"
 
   end subroutine rt_data_9
 
 @ %def rt_data_9
 @
 \subsubsection{Descriptions}
 <<RT data: execute tests>>=
   call test(rt_data_10, "rt_data_10", &
             "descriptions", u, results)
 <<RT data: test declarations>>=
   public :: rt_data_10
 <<RT data: tests>>=
   subroutine rt_data_10 (u)
     integer, intent(in) :: u
     type(rt_data_t) :: global
     ! type(var_list_t) :: var_list
     write (u, "(A)")  "* Test output: rt_data_10"
     write (u, "(A)")  "*   Purpose: display descriptions"
     write (u, "(A)")
 
     call global%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.'))
     call global%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.'))
     call global%var_list%append_int (var_str ("seed"), 1234, &
           intrinsic=.true., &
           description=var_str ('Integer variable \ttt{seed = {\em <num>}} ' // &
           'that allows to set a specific random seed \ttt{num}.'))
     call global%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.'))
     call global%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 global%var_list%sort ()
 
     call global%write_var_descriptions (u)
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_10"
   end subroutine rt_data_10
 
 @ %def rt_data_10
 @
 \subsubsection{Export objects}
 Export objects are variables or other data that should be copied or otherwise
 applied to corresponding objects in the outer scope.
 
 We test appending and retrieval for the export list.
 <<RT data: execute tests>>=
   call test(rt_data_11, "rt_data_11", &
             "export objects", u, results)
 <<RT data: test declarations>>=
   public :: rt_data_11
 <<RT data: tests>>=
   subroutine rt_data_11 (u)
     integer, intent(in) :: u
     type(rt_data_t) :: global
     type(string_t), dimension(:), allocatable :: exports
     integer :: i
 
     write (u, "(A)")  "* Test output: rt_data_11"
     write (u, "(A)")  "*   Purpose: handle export object list"
     write (u, "(A)")
 
     write (u, "(A)")  "* Empty export list"
     write (u, "(A)")
 
     call global%write_exports (u)
 
     write (u, "(A)")  "* Add an entry"
     write (u, "(A)")
 
     allocate (exports (1))
     exports(1) = var_str ("results")
     do i = 1, size (exports)
        write (u, "('+ ',A)")  char (exports(i))
     end do
     write (u, *)
 
     call global%append_exports (exports)
     call global%write_exports (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Add more entries, including doubler"
     write (u, "(A)")
 
     deallocate (exports)
     allocate (exports (3))
     exports(1) = var_str ("foo")
     exports(2) = var_str ("results")
     exports(3) = var_str ("bar")
     do i = 1, size (exports)
        write (u, "('+ ',A)")  char (exports(i))
     end do
     write (u, *)
 
     call global%append_exports (exports)
     call global%write_exports (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: rt_data_11"
   end subroutine rt_data_11
 
 @ %def rt_data_11
 @
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Select implementations}
 For abstract types (process core, integrator, phase space, etc.), we need a
 way to dynamically select a concrete type, using either data given by the user
 or a previous selection of a concrete type.  This is done by subroutines in
 the current module.
 
 We would like to put this in the [[me_methods]] folder but it also
 depends on [[gosam]] and [[openloops]], so it is unclear where to put
 it.
 <<[[dispatch_me_methods.f90]]>>=
 <<File header>>
 
 module dispatch_me_methods
 
 <<Use strings>>
 <<Use debug>>
   use physics_defs, only: BORN
   use diagnostics
   use sm_qcd
   use variables, only: var_list_t
   use models
   use model_data
 
   use prc_core_def
   use prc_core
   use prc_test_core
   use prc_template_me
   use prc_test
   use prc_omega
   use prc_external
   use prc_gosam
   use prc_openloops
   use prc_recola
   use prc_threshold
 
 <<Standard module head>>
 
 <<Dispatch me methods: public>>
 
 contains
 
 <<Dispatch me methods: procedures>>
 
 end module dispatch_me_methods
 @ %def dispatch_me_methods
 @
 \subsection{Process Core Definition}
 The [[prc_core_def_t]] abstract type can be instantiated by providing a
 [[$method]] string variable.
 <<Dispatch me methods: public>>=
   public :: dispatch_core_def
 <<Dispatch me methods: procedures>>=
   subroutine dispatch_core_def (core_def, prt_in, prt_out, &
        model, var_list, id, nlo_type, method)
     class(prc_core_def_t), allocatable, intent(out) :: core_def
     type(string_t), dimension(:), intent(in) :: prt_in
     type(string_t), dimension(:), intent(in) :: prt_out
     type(model_t), pointer, intent(in) :: model
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in), optional :: id
     integer, intent(in), optional :: nlo_type
     type(string_t), intent(in), optional :: method
     type(string_t) :: model_name, meth
     type(string_t) :: ufo_path
     type(string_t) :: restrictions
     logical :: ufo
     logical :: cms_scheme
     logical :: openmp_support
     logical :: report_progress
     logical :: diags, diags_color
     logical :: write_phs_output
     type(string_t) :: extra_options, correction_type
     integer :: nlo
     integer :: alpha_power
     integer :: alphas_power
     if (present (method)) then
        meth = method
     else
        meth = var_list%get_sval (var_str ("$method"))
     end if
     if (debug_on) call msg_debug2 (D_CORE, "dispatch_core_def")
     if (associated (model)) then
        model_name = model%get_name ()
        cms_scheme = model%get_scheme () == "Complex_Mass_Scheme"
        ufo = model%is_ufo_model ()
        ufo_path = model%get_ufo_path ()
     else
        model_name = ""
        cms_scheme = .false.
        ufo = .false.
     end if
     restrictions = var_list%get_sval (&
          var_str ("$restrictions"))
     diags = var_list%get_lval (&
          var_str ("?vis_diags"))
     diags_color = var_list%get_lval (&
          var_str ("?vis_diags_color"))
     openmp_support = var_list%get_lval (&
          var_str ("?omega_openmp"))
     report_progress = var_list%get_lval (&
          var_str ("?report_progress"))
     write_phs_output = var_list%get_lval (&
          var_str ("?omega_write_phs_output"))
     extra_options = var_list%get_sval (&
          var_str ("$omega_flags"))
     nlo = BORN;  if (present (nlo_type))  nlo = nlo_type
     alpha_power = var_list%get_ival (var_str ("alpha_power"))
     alphas_power = var_list%get_ival (var_str ("alphas_power"))
     correction_type = var_list%get_sval (var_str ("$nlo_correction_type"))
     if (debug_on) call msg_debug2 (D_CORE, "dispatching core method: ", meth)
     select case (char (meth))
     case ("unit_test")
        allocate (prc_test_def_t :: core_def)
        select type (core_def)
        type is (prc_test_def_t)
           call core_def%init (model_name, prt_in, prt_out)
        end select
     case ("template")
        allocate (template_me_def_t :: core_def)
        select type (core_def)
        type is (template_me_def_t)
           call core_def%init (model, prt_in, prt_out, unity = .false.)
        end select
     case ("template_unity")
        allocate (template_me_def_t :: core_def)
        select type (core_def)
        type is (template_me_def_t)
           call core_def%init (model, prt_in, prt_out, unity = .true.)
        end select
     case ("omega")
        allocate (omega_def_t :: core_def)
        select type (core_def)
        type is (omega_def_t)
           call core_def%init (model_name, prt_in, prt_out, &
                .false., ufo, ufo_path, &
                restrictions, cms_scheme, &
                openmp_support, report_progress, write_phs_output, &
                extra_options, diags, diags_color)
        end select
     case ("ovm")
        allocate (omega_def_t :: core_def)
        select type (core_def)
        type is (omega_def_t)
           call core_def%init (model_name, prt_in, prt_out, &
                .true., .false., var_str (""), &
                restrictions, cms_scheme, &
                openmp_support, report_progress, write_phs_output, &
                extra_options, diags, diags_color)
        end select
     case ("gosam")
       allocate (gosam_def_t :: core_def)
       select type (core_def)
       type is (gosam_def_t)
         if (present (id)) then
            call core_def%init (id, model_name, prt_in, &
                 prt_out, nlo, restrictions, var_list)
         else
            call msg_fatal ("Dispatch GoSam def: No id!")
         end if
       end select
     case ("openloops")
        allocate (openloops_def_t :: core_def)
        select type (core_def)
        type is (openloops_def_t)
           if (present (id)) then
              call core_def%init (id, model_name, prt_in, &
                   prt_out, nlo, restrictions, var_list)
           else
              call msg_fatal ("Dispatch OpenLoops def: No id!")
           end if
        end select
     case ("recola")
        call abort_if_recola_not_active ()
        allocate (recola_def_t :: core_def)
        select type (core_def)
        type is (recola_def_t)
           if (present (id)) then
              call core_def%init (id, model_name, prt_in, prt_out, &
                   nlo, alpha_power, alphas_power, correction_type, &
                   restrictions)
           else
              call msg_fatal ("Dispatch RECOLA def: No id!")
           end if
        end select
     case ("dummy")
        allocate (prc_external_test_def_t :: core_def)
        select type (core_def)
        type is (prc_external_test_def_t)
           if (present (id)) then
              call core_def%init (id, model_name, prt_in, prt_out)
           else
              call msg_fatal ("Dispatch User-Defined Test def: No id!")
           end if
        end select
     case ("threshold")
        allocate (threshold_def_t :: core_def)
        select type (core_def)
        type is (threshold_def_t)
           if (present (id)) then
              call core_def%init (id, model_name, prt_in, prt_out, &
                   nlo, restrictions)
           else
              call msg_fatal ("Dispatch Threshold def: No id!")
           end if
        end select
     case default
        call msg_fatal ("Process configuration: method '" &
             // char (meth) // "' not implemented")
     end select
   end subroutine dispatch_core_def
 
 @ %def dispatch_core_def
 @
 \subsection{Process core allocation}
 Here we allocate an object of abstract type [[prc_core_t]] with a concrete
 type that matches a process definition.  The [[prc_omega_t]] extension
 will require the current parameter set, so we take the opportunity to
 grab it from the model.
 <<Dispatch me methods: public>>=
   public :: dispatch_core
 <<Dispatch me methods: procedures>>=
   subroutine dispatch_core (core, core_def, model, &
        helicity_selection, qcd, use_color_factors, has_beam_pol)
     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
     select type (core_def)
     type is (prc_test_def_t)
        allocate (test_t :: core)
     type is (template_me_def_t)
        allocate (prc_template_me_t :: core)
        select type (core)
        type is (prc_template_me_t)
           call core%set_parameters (model)
        end select
     class is (omega_def_t)
        if (.not. allocated (core)) allocate (prc_omega_t :: core)
        select type (core)
        type is (prc_omega_t)
           call core%set_parameters (model, &
                helicity_selection, qcd, use_color_factors)
        end select
     type is (gosam_def_t)
       if (.not. allocated (core)) allocate (prc_gosam_t :: core)
       select type (core)
       type is (prc_gosam_t)
         call core%set_parameters (qcd)
       end select
     type is (openloops_def_t)
       if (.not. allocated (core)) allocate (prc_openloops_t :: core)
       select type (core)
       type is (prc_openloops_t)
          call core%set_parameters (qcd)
       end select
     type is (recola_def_t)
       if (.not. allocated (core)) allocate (prc_recola_t :: core)
       select type (core)
       type is (prc_recola_t)
          call core%set_parameters (qcd, model)
       end select
     type is (prc_external_test_def_t)
       if (.not. allocated (core)) allocate (prc_external_test_t :: core)
       select type (core)
       type is (prc_external_test_t)
          call core%set_parameters (qcd, model)
       end select
     type is (threshold_def_t)
       if (.not. allocated (core)) allocate (prc_threshold_t :: core)
       select type (core)
       type is (prc_threshold_t)
          call core%set_parameters (qcd, model)
          call core%set_beam_pol (has_beam_pol)
       end select
     class default
        call msg_bug ("Process core: unexpected process definition type")
     end select
   end subroutine dispatch_core
 
 @ %def dispatch_core
 @
 \subsection{Process core update and restoration}
 Here we take an existing object of abstract type [[prc_core_t]] and
 update the parameters as given by the current state of [[model]].
 Optionally, we can save the previous state as [[saved_core]].  The
 second routine restores the original from the save.
 
 (In the test case, there is no possible update.)
 <<Dispatch me methods: public>>=
   public :: dispatch_core_update
   public :: dispatch_core_restore
 <<Dispatch me methods: procedures>>=
   subroutine dispatch_core_update &
        (core, model, helicity_selection, qcd, saved_core)
 
     class(prc_core_t), allocatable, intent(inout) :: core
     class(model_data_t), intent(in), optional, target :: model
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     type(qcd_t), intent(in), optional :: qcd
     class(prc_core_t), allocatable, intent(inout), optional :: saved_core
 
     if (present (saved_core)) then
        allocate (saved_core, source = core)
     end if
     select type (core)
     type is (test_t)
     type is (prc_omega_t)
        call core%set_parameters (model, helicity_selection, qcd)
        call core%activate_parameters ()
     class is (prc_external_t)
       call msg_message ("Updating user defined cores is not implemented yet.")
     class default
        call msg_bug ("Process core update: unexpected process definition type")
     end select
   end subroutine dispatch_core_update
 
   subroutine dispatch_core_restore (core, saved_core)
 
     class(prc_core_t), allocatable, intent(inout) :: core
     class(prc_core_t), allocatable, intent(inout) :: saved_core
 
     call move_alloc (from = saved_core, to = core)
     select type (core)
     type is (test_t)
     type is (prc_omega_t)
        call core%activate_parameters ()
     class default
        call msg_bug ("Process core restore: unexpected process definition type")
     end select
   end subroutine dispatch_core_restore
 
 @ %def dispatch_core_update dispatch_core_restore
 @
 \subsection{Unit Tests}
 Test module, followed by the corresponding implementation module.
 <<[[dispatch_ut.f90]]>>=
 <<File header>>
 
 module dispatch_ut
   use unit_tests
   use dispatch_uti
 
 <<Standard module head>>
 
 <<Dispatch: public test>>
 
 <<Dispatch: public test auxiliary>>
 
 contains
 
 <<Dispatch: test driver>>
 
 end module dispatch_ut
 @ %def dispatch_ut
 @
 <<[[dispatch_uti.f90]]>>=
 <<File header>>
 
 module dispatch_uti
 <<Use kinds>>
 <<Use strings>>
   use os_interface, only: os_data_t
   use physics_defs, only: ELECTRON, PROTON
   use sm_qcd, only: qcd_t
   use flavors, only: flavor_t
   use interactions, only: reset_interaction_counter
   use pdg_arrays, only: pdg_array_t, assignment(=)
   use prc_core_def, only: prc_core_def_t
   use prc_test_core, only: test_t
   use prc_core, only: prc_core_t
   use prc_test, only: prc_test_def_t
   use prc_omega, only: omega_def_t, prc_omega_t
   use sf_mappings, only: sf_channel_t
   use sf_base, only: sf_data_t, sf_config_t
   use phs_base, only: phs_channel_collection_t
   use variables, only: var_list_t
   use model_data, only: model_data_t
   use models, only: syntax_model_file_init, syntax_model_file_final
   use rt_data, only: rt_data_t
 
   use dispatch_phase_space, only: dispatch_sf_channels
   use dispatch_beams, only: sf_prop_t, dispatch_qcd
   use dispatch_beams, only: dispatch_sf_config, dispatch_sf_data
   use dispatch_me_methods, only: dispatch_core_def, dispatch_core
   use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore
 
   use sf_base_ut, only: sf_test_data_t
 
 <<Standard module head>>
 
 <<Dispatch: public test auxiliary>>
 
 <<Dispatch: test declarations>>
 
 contains
 
 <<Dispatch: tests>>
 
 <<Dispatch: test auxiliary>>
 
 end module dispatch_uti
 
 @ %def dispatch_uti
 @ API: driver for the unit tests below.
 <<Dispatch: public test>>=
   public :: dispatch_test
 <<Dispatch: test driver>>=
   subroutine dispatch_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Dispatch: execute tests>>
   end subroutine dispatch_test
 
 @ %def dispatch_test
 @
 \subsubsection{Select type: process definition}
 <<Dispatch: execute tests>>=
   call test (dispatch_1, "dispatch_1", &
        "process configuration method", &
        u, results)
 <<Dispatch: test declarations>>=
   public :: dispatch_1
 <<Dispatch: tests>>=
   subroutine dispatch_1 (u)
     integer, intent(in) :: u
     type(string_t), dimension(2) :: prt_in, prt_out
     type(rt_data_t), target :: global
     class(prc_core_def_t), allocatable :: core_def
 
     write (u, "(A)")  "* Test output: dispatch_1"
     write (u, "(A)")  "*   Purpose: select process configuration method"
     write (u, "(A)")
 
     call global%global_init ()
 
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     prt_in = [var_str ("a"), var_str ("b")]
     prt_out = [var_str ("c"), var_str ("d")]
 
     write (u, "(A)")  "* Allocate core_def as prc_test_def"
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
     select type (core_def)
     type is (prc_test_def_t)
        call core_def%write (u)
     end select
 
     deallocate (core_def)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate core_def as omega_def"
     write (u, "(A)")
 
     call global%set_string (var_str ("$method"), &
          var_str ("omega"), is_known = .true.)
     call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
     select type (core_def)
     type is (omega_def_t)
        call core_def%write (u)
     end select
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: dispatch_1"
 
   end subroutine dispatch_1
 
 @ %def dispatch_1
 @
 \subsubsection{Select type: process core}
 <<Dispatch: execute tests>>=
   call test (dispatch_2, "dispatch_2", &
        "process core", &
        u, results)
 <<Dispatch: test declarations>>=
   public :: dispatch_2
 <<Dispatch: tests>>=
   subroutine dispatch_2 (u)
     integer, intent(in) :: u
     type(string_t), dimension(2) :: prt_in, prt_out
     type(rt_data_t), target :: global
     class(prc_core_def_t), allocatable :: core_def
     class(prc_core_t), allocatable :: core
 
     write (u, "(A)")  "* Test output: dispatch_2"
     write (u, "(A)")  "*   Purpose: select process configuration method"
     write (u, "(A)")  "             and allocate process core"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call global%global_init ()
 
     prt_in = [var_str ("a"), var_str ("b")]
     prt_out = [var_str ("c"), var_str ("d")]
 
     write (u, "(A)")  "* Allocate core as test_t"
     write (u, "(A)")
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
     call dispatch_core (core, core_def)
     select type (core)
     type is (test_t)
        call core%write (u)
     end select
 
     deallocate (core)
     deallocate (core_def)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate core as prc_omega_t"
     write (u, "(A)")
 
     call global%set_string (var_str ("$method"), &
          var_str ("omega"), is_known = .true.)
     call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
 
     call global%select_model (var_str ("Test"))
 
     call global%set_log (&
          var_str ("?helicity_selection_active"), &
          .true., is_known = .true.)
     call global%set_real (&
          var_str ("helicity_selection_threshold"), &
          1e9_default, is_known = .true.)
     call global%set_int (&
          var_str ("helicity_selection_cutoff"), &
          10, is_known = .true.)
 
     call dispatch_core (core, core_def, &
          global%model, &
          global%get_helicity_selection ())
     call core_def%allocate_driver (core%driver, var_str (""))
 
     select type (core)
     type is (prc_omega_t)
        call core%write (u)
     end select
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: dispatch_2"
 
   end subroutine dispatch_2
 
 @ %def dispatch_2
 @
 \subsubsection{Select type: structure-function data}
 This is an extra dispatcher that enables the test structure
 functions.  This procedure should be assigned to the
 [[dispatch_sf_data_extra]] hook before any tests are executed.
 <<Dispatch: public test auxiliary>>=
   public :: dispatch_sf_data_test
 <<Dispatch: test auxiliary>>=
   subroutine dispatch_sf_data_test (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(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
     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
     logical, intent(in) :: polarized
     select case (char (sf_method))
     case ("sf_test_0", "sf_test_1")
        allocate (sf_test_data_t :: data)
        select type (data)
        type is (sf_test_data_t)
           select case (char (sf_method))
           case ("sf_test_0");  call data%init (model, pdg_in(i_beam(1)))
           case ("sf_test_1");  call data%init (model, pdg_in(i_beam(1)),&
                mode = 1)
           end select
        end select
     end select
   end subroutine dispatch_sf_data_test
 
 @ %def dispatch_sf_data_test
 @ The actual test. We can't move this to [[beams]] as it depends on
 [[model_features]] for the [[model_list_t]].
 <<Dispatch: execute tests>>=
   call test (dispatch_7, "dispatch_7", &
        "structure-function data", &
        u, results)
 <<Dispatch: test declarations>>=
   public :: dispatch_7
 <<Dispatch: tests>>=
   subroutine dispatch_7 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     type(os_data_t) :: os_data
     type(string_t) :: prt, sf_method
     type(sf_prop_t) :: sf_prop
     class(sf_data_t), allocatable :: data
     type(pdg_array_t), dimension(1) :: pdg_in
     type(pdg_array_t), dimension(1,1) :: pdg_prc
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
 
     write (u, "(A)")  "* Test output: dispatch_7"
     write (u, "(A)")  "*   Purpose: select and configure &
          &structure function data"
     write (u, "(A)")
 
     call global%global_init ()
 
     call os_data%init ()
     call syntax_model_file_init ()
     call global%select_model (var_str ("QCD"))
 
     call reset_interaction_counter ()
     call global%set_real (var_str ("sqrts"), &
          14000._default, is_known = .true.)
     prt = "p"
     call global%beam_structure%init_sf ([prt, prt], [1])
     pdg_in = 2212
 
     write (u, "(A)")  "* Allocate data as sf_pdf_builtin_t"
     write (u, "(A)")
 
     sf_method = "pdf_builtin"
     call dispatch_sf_data (data, sf_method, [1], sf_prop, &
          global%get_var_list_ptr (), global%var_list, &
          global%model, global%os_data, global%get_sqrts (), &
          pdg_in, pdg_prc, .false.)
     call data%write (u)
 
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(A)")
     write (u, "(1x,A,99(1x,I0))")  "PDG(out) = ", pdg1
 
     deallocate (data)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate data for different PDF set"
     write (u, "(A)")
 
     pdg_in = 2212
 
     call global%set_string (var_str ("$pdf_builtin_set"), &
          var_str ("CTEQ6M"), is_known = .true.)
     sf_method = "pdf_builtin"
     call dispatch_sf_data (data, sf_method, [1], sf_prop, &
          global%get_var_list_ptr (), global%var_list, &
          global%model, global%os_data, global%get_sqrts (), &
          pdg_in, pdg_prc, .false.)
     call data%write (u)
 
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(A)")
     write (u, "(1x,A,99(1x,I0))")  "PDG(out) = ", pdg1
 
     deallocate (data)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: dispatch_7"
 
   end subroutine dispatch_7
 
 @ %def dispatch_7
 @
 \subsubsection{Beam structure}
 The actual test. We can't move this to [[beams]] as it depends on
 [[model_features]] for the [[model_list_t]].
 <<Dispatch: execute tests>>=
   call test (dispatch_8, "dispatch_8", &
        "beam structure", &
        u, results)
 <<Dispatch: test declarations>>=
   public :: dispatch_8
 <<Dispatch: tests>>=
   subroutine dispatch_8 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     type(os_data_t) :: os_data
     type(flavor_t), dimension(2) :: flv
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_prop_t) :: sf_prop
     type(sf_channel_t), dimension(:), allocatable :: sf_channel
     type(phs_channel_collection_t) :: coll
     type(string_t) :: sf_string
     integer :: i
     type(pdg_array_t), dimension (2,1) :: pdg_prc
 
     write (u, "(A)")  "* Test output: dispatch_8"
     write (u, "(A)")  "*   Purpose: configure a structure-function chain"
     write (u, "(A)")
 
     call global%global_init ()
 
     call os_data%init ()
     call syntax_model_file_init ()
     call global%select_model (var_str ("QCD"))
 
     write (u, "(A)")  "* Allocate LHC beams with PDF builtin"
     write (u, "(A)")
 
     call flv(1)%init (PROTON, global%model)
     call flv(2)%init (PROTON, global%model)
 
     call reset_interaction_counter ()
     call global%set_real (var_str ("sqrts"), &
          14000._default, is_known = .true.)
 
     call global%beam_structure%init_sf (flv%get_name (), [1])
     call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin"))
 
     call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, &
          global%get_var_list_ptr (), global%var_list, &
          global%model, global%os_data, global%get_sqrts (), pdg_prc)
     do i = 1, size (sf_config)
        call sf_config(i)%write (u)
     end do
 
     call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, &
          global%var_list, global%get_sqrts(), global%beam_structure)
     write (u, "(1x,A)")  "Mapping configuration:"
     do i = 1, size (sf_channel)
        write (u, "(2x)", advance = "no")
        call sf_channel(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate ILC beams with CIRCE1"
     write (u, "(A)")
 
     call global%select_model (var_str ("QED"))
     call flv(1)%init ( ELECTRON, global%model)
     call flv(2)%init (-ELECTRON, global%model)
 
     call reset_interaction_counter ()
     call global%set_real (var_str ("sqrts"), &
          500._default, is_known = .true.)
     call global%set_log (var_str ("?circe1_generate"), &
          .false., is_known = .true.)
 
     call global%beam_structure%init_sf (flv%get_name (), [1])
     call global%beam_structure%set_sf (1, 1, var_str ("circe1"))
 
     call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, &
          global%get_var_list_ptr (), global%var_list, &
          global%model, global%os_data, global%get_sqrts (), pdg_prc)
     do i = 1, size (sf_config)
        call sf_config(i)%write (u)
     end do
 
     call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, &
          global%var_list, global%get_sqrts(), global%beam_structure)
     write (u, "(1x,A)")  "Mapping configuration:"
     do i = 1, size (sf_channel)
        write (u, "(2x)", advance = "no")
        call sf_channel(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: dispatch_8"
 
   end subroutine dispatch_8
 
 @ %def dispatch_8
 @
 \subsubsection{Update process core parameters}
 This test dispatches a process core, temporarily modifies parameters,
 then restores the original.
 <<Dispatch: execute tests>>=
   call test (dispatch_10, "dispatch_10", &
        "process core update", &
        u, results)
 <<Dispatch: test declarations>>=
   public :: dispatch_10
 <<Dispatch: tests>>=
   subroutine dispatch_10 (u)
     integer, intent(in) :: u
     type(string_t), dimension(2) :: prt_in, prt_out
     type(rt_data_t), target :: global
     class(prc_core_def_t), allocatable :: core_def
     class(prc_core_t), allocatable :: core, saved_core
     type(var_list_t), pointer :: model_vars
 
     write (u, "(A)")  "* Test output: dispatch_10"
     write (u, "(A)")  "*   Purpose: select process configuration method,"
     write (u, "(A)")  "             allocate process core,"
     write (u, "(A)")  "             temporarily reset parameters"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call global%global_init ()
 
     prt_in = [var_str ("a"), var_str ("b")]
     prt_out = [var_str ("c"), var_str ("d")]
 
     write (u, "(A)")  "* Allocate core as prc_omega_t"
     write (u, "(A)")
 
     call global%set_string (var_str ("$method"), &
          var_str ("omega"), is_known = .true.)
     call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
 
     call global%select_model (var_str ("Test"))
 
     call dispatch_core (core, core_def, global%model)
     call core_def%allocate_driver (core%driver, var_str (""))
 
     select type (core)
     type is (prc_omega_t)
        call core%write (u)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Update core with modified model and helicity selection"
     write (u, "(A)")
 
     model_vars => global%model%get_var_list_ptr ()
 
     call model_vars%set_real (var_str ("gy"), 2._default, &
          is_known = .true.)
     call global%model%update_parameters ()
 
     call global%set_log (&
          var_str ("?helicity_selection_active"), &
          .true., is_known = .true.)
     call global%set_real (&
          var_str ("helicity_selection_threshold"), &
          2e10_default, is_known = .true.)
     call global%set_int (&
          var_str ("helicity_selection_cutoff"), &
          5, is_known = .true.)
 
     call dispatch_core_update (core, &
          global%model, &
          global%get_helicity_selection (), &
          saved_core = saved_core)
     select type (core)
     type is (prc_omega_t)
        call core%write (u)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Restore core from save"
     write (u, "(A)")
 
     call dispatch_core_restore (core, saved_core)
     select type (core)
     type is (prc_omega_t)
        call core%write (u)
     end select
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: dispatch_10"
 
   end subroutine dispatch_10
 
 @ %def dispatch_10
 @
 \subsubsection{QCD Coupling}
 This test dispatches an [[qcd]] object, which is used to compute the
 (running) coupling by one of several possible methods.
 
 We can't move this to [[beams]] as it depends on
 [[model_features]] for the [[model_list_t]].
 <<Dispatch: execute tests>>=
   call test (dispatch_11, "dispatch_11", &
        "QCD coupling", &
        u, results)
 <<Dispatch: test declarations>>=
   public :: dispatch_11
 <<Dispatch: tests>>=
   subroutine dispatch_11 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     type(var_list_t), pointer :: model_vars
     type(qcd_t) :: qcd
 
     write (u, "(A)")  "* Test output: dispatch_11"
     write (u, "(A)")  "*   Purpose: select QCD coupling formula"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call global%global_init ()
     call global%select_model (var_str ("SM"))
     model_vars => global%get_var_list_ptr ()
 
     write (u, "(A)")  "* Allocate alpha_s as fixed"
     write (u, "(A)")
 
     call global%set_log (var_str ("?alphas_is_fixed"), &
          .true., is_known = .true.)
     call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
     call qcd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate alpha_s as running (built-in)"
     write (u, "(A)")
 
     call global%set_log (var_str ("?alphas_is_fixed"), &
          .false., is_known = .true.)
     call global%set_log (var_str ("?alphas_from_mz"), &
          .true., is_known = .true.)
     call global%set_int &
          (var_str ("alphas_order"), 1, is_known = .true.)
     call model_vars%set_real (var_str ("alphas"), 0.1234_default, &
           is_known=.true.)
     call model_vars%set_real (var_str ("mZ"), 91.234_default, &
           is_known=.true.)
     call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
     call qcd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate alpha_s as running (built-in, Lambda defined)"
     write (u, "(A)")
 
     call global%set_log (var_str ("?alphas_from_mz"), &
          .false., is_known = .true.)
     call global%set_log (&
          var_str ("?alphas_from_lambda_qcd"), &
          .true., is_known = .true.)
     call global%set_real &
          (var_str ("lambda_qcd"), 250.e-3_default, &
           is_known=.true.)
     call global%set_int &
          (var_str ("alphas_order"), 2, is_known = .true.)
     call global%set_int &
          (var_str ("alphas_nf"), 4, is_known = .true.)
     call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
     call qcd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate alpha_s as running (using builtin PDF set)"
     write (u, "(A)")
 
     call global%set_log (&
          var_str ("?alphas_from_lambda_qcd"), &
          .false., is_known = .true.)
     call global%set_log &
          (var_str ("?alphas_from_pdf_builtin"), &
          .true., is_known = .true.)
     call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
     call qcd%write (u)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: dispatch_11"
 
   end subroutine dispatch_11
 
 @ %def dispatch_11
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process Configuration}
 This module communicates between the toplevel command structure with
 its runtime data set and the process-library handling modules which
 collect the definition of individual processes.  Its primary purpose
 is to select from the available matrix-element generating methods and
 configure the entry in the process library accordingly.
 <<[[process_configurations.f90]]>>=
 <<File header>>
 
 module process_configurations
 
 <<Use strings>>
 <<Use debug>>
   use diagnostics
   use io_units
   use physics_defs, only: BORN, NLO_VIRTUAL, NLO_REAL, NLO_DGLAP, &
        NLO_SUBTRACTION, NLO_MISMATCH
   use models
   use prc_core_def
   use particle_specifiers
   use process_libraries
   use rt_data
   use variables, only: var_list_t
 
   use dispatch_me_methods, only: dispatch_core_def
   use prc_external, only: prc_external_def_t
 
 <<Standard module head>>
 
 <<Process configurations: public>>
 
 <<Process configurations: types>>
 
 contains
 
 <<Process configurations: procedures>>
 
 end module process_configurations
 @ %def process_configurations
 @
 \subsection{Data Type}
 <<Process configurations: public>>=
   public :: process_configuration_t
 <<Process configurations: types>>=
   type :: process_configuration_t
      type(process_def_entry_t), pointer :: entry => null ()
      type(string_t) :: id
      integer :: num_id = 0
    contains
    <<Process configurations: process configuration: TBP>>
   end type process_configuration_t
 
 @ %def process_configuration_t
 @ Output (for unit tests).
 <<Process configurations: process configuration: TBP>>=
   procedure :: write => process_configuration_write
 <<Process configurations: procedures>>=
   subroutine process_configuration_write (config, unit)
     class(process_configuration_t), intent(in) :: config
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(A)")  "Process configuration:"
     if (associated (config%entry)) then
        call config%entry%write (u)
     else
        write (u, "(1x,3A)")  "ID    = '", char (config%id), "'"
        write (u, "(1x,A,1x,I0)")  "num ID =", config%num_id
        write (u, "(2x,A)")  "[no entry]"
     end if
   end subroutine process_configuration_write
 
 @ %def process_configuration_write
 @ Initialize a process.  We only need the name, the number of incoming
 particles, and the number of components.
 <<Process configurations: process configuration: TBP>>=
   procedure :: init => process_configuration_init
 <<Process configurations: procedures>>=
   subroutine process_configuration_init &
        (config, prc_name, n_in, n_components, model, var_list, nlo_process)
     class(process_configuration_t), intent(out) :: config
     type(string_t), intent(in) :: prc_name
     integer, intent(in) :: n_in
     integer, intent(in) :: n_components
     type(model_t), intent(in), pointer :: model
     type(var_list_t), intent(in) :: var_list
     logical, intent(in), optional :: nlo_process
     logical :: nlo_proc
     logical :: requires_resonances
     if (debug_on) call msg_debug (D_CORE, "process_configuration_init")
     config%id = prc_name
     if (present (nlo_process)) then
        nlo_proc = nlo_process
     else
        nlo_proc = .false.
     end if
     requires_resonances = var_list%get_lval (var_str ("?resonance_history"))
 
     if (debug_on) call msg_debug (D_CORE, "nlo_process", nlo_proc)
     allocate (config%entry)
     if (var_list%is_known (var_str ("process_num_id"))) then
        config%num_id = &
             var_list%get_ival (var_str ("process_num_id"))
        call config%entry%init (prc_name, &
             model = model, n_in = n_in, n_components = n_components, &
             num_id = config%num_id, &
             nlo_process = nlo_proc, &
             requires_resonances = requires_resonances)
     else
        call config%entry%init (prc_name, &
             model = model, n_in = n_in, n_components = n_components, &
             nlo_process = nlo_proc, &
             requires_resonances = requires_resonances)
     end if
   end subroutine process_configuration_init
 
 @ %def process_configuration_init
 @ Initialize a process component.  The details depend on the process method,
 which determines the type of the process component core.  We set the incoming
 and outgoing particles (as strings, to be interpreted by the process driver).
 All other information is taken from the variable list.
 
 The dispatcher gets only the names of the particles.  The process
 component definition gets the complete specifiers which contains a
 polarization flag and names of decay processes, where applicable.
 <<Process configurations: process configuration: TBP>>=
   procedure :: setup_component => process_configuration_setup_component
 <<Process configurations: procedures>>=
   subroutine process_configuration_setup_component &
        (config, i_component, prt_in, prt_out, model, var_list, &
         nlo_type, can_be_integrated)
     class(process_configuration_t), intent(inout) :: config
     integer, intent(in) :: i_component
     type(prt_spec_t), dimension(:), intent(in) :: prt_in
     type(prt_spec_t), dimension(:), intent(in) :: prt_out
     type(model_t), pointer, intent(in) :: model
     type(var_list_t), intent(in) :: var_list
     integer, intent(in), optional :: nlo_type
     logical, intent(in), optional :: can_be_integrated
     type(string_t), dimension(:), allocatable :: prt_str_in
     type(string_t), dimension(:), allocatable :: prt_str_out
     class(prc_core_def_t), allocatable :: core_def
     type(string_t) :: method
     type(string_t) :: born_me_method
     type(string_t) :: real_tree_me_method
     type(string_t) :: loop_me_method
     type(string_t) :: correlation_me_method
     type(string_t) :: dglap_me_method
     integer :: i
     if (debug_on) call msg_debug2 (D_CORE, "process_configuration_setup_component")
     allocate (prt_str_in  (size (prt_in)))
     allocate (prt_str_out (size (prt_out)))
     forall (i = 1:size (prt_in))  prt_str_in(i)  = prt_in(i)% get_name ()
     forall (i = 1:size (prt_out)) prt_str_out(i) = prt_out(i)%get_name ()
 
     method = var_list%get_sval (var_str ("$method"))
     if (present (nlo_type)) then
        select case (nlo_type)
        case (BORN)
           born_me_method = var_list%get_sval (var_str ("$born_me_method"))
           if (born_me_method /= var_str ("")) then
              method = born_me_method
           end if
        case (NLO_VIRTUAL)
           loop_me_method = var_list%get_sval (var_str ("$loop_me_method"))
           if (loop_me_method /= var_str ("")) then
              method = loop_me_method
           end if
        case (NLO_REAL)
           real_tree_me_method = &
                var_list%get_sval (var_str ("$real_tree_me_method"))
           if (real_tree_me_method /= var_str ("")) then
              method = real_tree_me_method
           end if
        case (NLO_DGLAP)
           dglap_me_method = &
                var_list%get_sval (var_str ("$dglap_me_method"))
           if (dglap_me_method /= var_str ("")) then
              method = dglap_me_method
           end if
        case (NLO_SUBTRACTION,NLO_MISMATCH)
           correlation_me_method = &
                var_list%get_sval (var_str ("$correlation_me_method"))
           if (correlation_me_method /= var_str ("")) then
              method = correlation_me_method
           end if
        case default
        end select
     end if
     call dispatch_core_def (core_def, prt_str_in, prt_str_out, &
          model, var_list, config%id, nlo_type, method)
     select type (core_def)
     class is (prc_external_def_t)
        if (present (can_be_integrated)) then
           call core_def%set_active_writer (can_be_integrated)
        else
           call msg_fatal ("Cannot decide if external core is integrated!")
        end if
     end select
 
     if (debug_on) call msg_debug2 (D_CORE, "import_component with method ", method)
     call config%entry%import_component (i_component, &
          n_out = size (prt_out), &
          prt_in = prt_in, &
          prt_out = prt_out, &
          method = method, &
          variant = core_def, &
          nlo_type = nlo_type, &
          can_be_integrated = can_be_integrated)
   end subroutine process_configuration_setup_component
 
 @ %def process_configuration_setup_component
 @
 <<Process configurations: process configuration: TBP>>=
   procedure :: set_fixed_emitter => process_configuration_set_fixed_emitter
 <<Process configurations: procedures>>=
   subroutine process_configuration_set_fixed_emitter (config, i, emitter)
      class(process_configuration_t), intent(inout) :: config
      integer, intent(in) :: i, emitter
      call config%entry%set_fixed_emitter (i, emitter)
   end subroutine process_configuration_set_fixed_emitter
 
 @ %def process_configuration_set_fixed_emitter
 @
 <<Process configurations: process configuration: TBP>>=
   procedure :: set_coupling_powers => process_configuration_set_coupling_powers
 <<Process configurations: procedures>>=
   subroutine process_configuration_set_coupling_powers &
        (config, alpha_power, alphas_power)
     class(process_configuration_t), intent(inout) :: config
     integer, intent(in) :: alpha_power, alphas_power
     call config%entry%set_coupling_powers (alpha_power, alphas_power)
   end subroutine process_configuration_set_coupling_powers
 
 @ %def process_configuration_set_coupling_powers
 @
 <<Process configurations: process configuration: TBP>>=
   procedure :: set_component_associations => &
        process_configuration_set_component_associations
 <<Process configurations: procedures>>=
   subroutine process_configuration_set_component_associations &
          (config, i_list, remnant, use_real_finite, mismatch)
     class(process_configuration_t), intent(inout) :: config
     integer, dimension(:), intent(in) :: i_list
     logical, intent(in) :: remnant, use_real_finite, mismatch
     integer :: i_component
     do i_component = 1, config%entry%get_n_components ()
        if (any (i_list == i_component)) then
           call config%entry%set_associated_components (i_component, &
                i_list, remnant, use_real_finite, mismatch)
        end if
     end do
   end subroutine process_configuration_set_component_associations
 
 @ %def process_configuration_set_component_associations
 @ Record a process configuration: append it to the currently selected process
 definition library.
 <<Process configurations: process configuration: TBP>>=
   procedure :: record => process_configuration_record
 <<Process configurations: procedures>>=
   subroutine process_configuration_record (config, global)
     class(process_configuration_t), intent(inout) :: config
     type(rt_data_t), intent(inout) :: global
     if (associated (global%prclib)) then
        call global%prclib%open ()
        call global%prclib%append (config%entry)
        if (config%num_id /= 0) then
           write (msg_buffer, "(5A,I0,A)") "Process library '", &
                char (global%prclib%get_name ()), &
                "': recorded process '", char (config%id), "' (", &
                config%num_id, ")"
        else
           write (msg_buffer, "(5A)") "Process library '", &
                char (global%prclib%get_name ()), &
                "': recorded process '", char (config%id), "'"
        end if
        call msg_message ()
     else
        call msg_fatal ("Recording process '" // char (config%id) &
             // "': active process library undefined")
     end if
   end subroutine process_configuration_record
 
 @ %def process_configuration_record
 @
 \subsection{Unit Tests}
 Test module, followed by the corresponding implementation module.
 <<[[process_configurations_ut.f90]]>>=
 <<File header>>
 
 module process_configurations_ut
   use unit_tests
   use process_configurations_uti
 
 <<Standard module head>>
 
 <<Process configurations: public test>>
 
 <<Process configurations: public test auxiliary>>
 
 contains
 
 <<Process configurations: test driver>>
 
 end module process_configurations_ut
 @ %def process_configurations_ut
 @
 <<[[process_configurations_uti.f90]]>>=
 <<File header>>
 
 module process_configurations_uti
 
 <<Use strings>>
   use particle_specifiers, only: new_prt_spec
   use prclib_stacks
   use models
   use rt_data
 
   use process_configurations
 
 <<Standard module head>>
 
 <<Process configurations: test declarations>>
 
 <<Process configurations: public test auxiliary>>
 
 contains
 
 <<Process configurations: test auxiliary>>
 
 <<Process configurations: tests>>
 
 end module process_configurations_uti
 
 @ %def process_configurations_uti
 @ API: driver for the unit tests below.
 <<Process configurations: public test>>=
   public :: process_configurations_test
 <<Process configurations: test driver>>=
   subroutine process_configurations_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Process configurations: execute tests>>
   end subroutine process_configurations_test
 
 @ %def process_configurations_test
 @
 \subsubsection{Minimal setup}
 The workflow for setting up a minimal process configuration with the
 test matrix element method.
 
 We wrap this in a public procedure, so we can reuse it in later modules.
 The procedure prepares a process definition list for two processes
 (one [[prc_test]] and one [[omega]] type) and appends this to the
 process library stack in the global data set.
 
 The [[mode]] argument determines which processes to build.
 
 The [[procname]] argument replaces the predefined procname(s).
 
 This is re-exported by the UT module.
 <<Process configurations: public test auxiliary>>=
   public :: prepare_test_library
 <<Process configurations: test auxiliary>>=
   subroutine prepare_test_library (global, libname, mode, procname)
     type(rt_data_t), intent(inout), target :: global
     type(string_t), intent(in) :: libname
     integer, intent(in) :: mode
     type(string_t), intent(in), dimension(:), optional :: procname
     type(prclib_entry_t), pointer :: lib
     type(string_t) :: prc_name
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     integer :: n_components
     type(process_configuration_t) :: prc_config
 
     if (.not. associated (global%prclib_stack%get_first_ptr ())) then
        allocate (lib)
        call lib%init (libname)
        call global%add_prclib (lib)
     end if
 
     if (btest (mode, 0)) then
 
        call global%select_model (var_str ("Test"))
 
        if (present (procname)) then
           prc_name = procname(1)
        else
           prc_name = "prc_config_a"
        end if
        n_components = 1
        allocate (prt_in (2), prt_out (2))
        prt_in = [var_str ("s"), var_str ("s")]
        prt_out = [var_str ("s"), var_str ("s")]
 
        call global%set_string (var_str ("$method"),&
             var_str ("unit_test"), is_known = .true.)
 
        call prc_config%init (prc_name, &
             size (prt_in), n_components, &
             global%model, global%var_list)
        call prc_config%setup_component (1, &
             new_prt_spec (prt_in), new_prt_spec (prt_out), &
             global%model, global%var_list)
        call prc_config%record (global)
 
        deallocate (prt_in, prt_out)
 
     end if
 
     if (btest (mode, 1)) then
 
        call global%select_model (var_str ("QED"))
 
        if (present (procname)) then
           prc_name = procname(2)
        else
           prc_name = "prc_config_b"
        end if
        n_components = 1
        allocate (prt_in (2), prt_out (2))
        prt_in = [var_str ("e+"), var_str ("e-")]
        prt_out = [var_str ("m+"), var_str ("m-")]
 
        call global%set_string (var_str ("$method"),&
             var_str ("omega"), is_known = .true.)
 
        call prc_config%init (prc_name, &
             size (prt_in), n_components, &
             global%model, global%var_list)
        call prc_config%setup_component (1, &
             new_prt_spec (prt_in), new_prt_spec (prt_out), &
             global%model, global%var_list)
        call prc_config%record (global)
 
        deallocate (prt_in, prt_out)
 
     end if
 
     if (btest (mode, 2)) then
 
        call global%select_model (var_str ("Test"))
 
        if (present (procname)) then
           prc_name = procname(1)
        else
           prc_name = "prc_config_a"
        end if
        n_components = 1
        allocate (prt_in (1), prt_out (2))
        prt_in = [var_str ("s")]
        prt_out = [var_str ("f"), var_str ("fbar")]
 
        call global%set_string (var_str ("$method"),&
             var_str ("unit_test"), is_known = .true.)
 
        call prc_config%init (prc_name, &
             size (prt_in), n_components, &
             global%model, global%var_list)
        call prc_config%setup_component (1, &
             new_prt_spec (prt_in), new_prt_spec (prt_out), &
             global%model, global%var_list)
        call prc_config%record (global)
 
        deallocate (prt_in, prt_out)
 
     end if
 
   end subroutine prepare_test_library
 
 @ %def prepare_test_library
 @ The actual test: the previous procedure with some prelude and postlude.
 In the global variable list, just before printing we reset the
 variables where the value may depend on the system and run environment.
 <<Process configurations: execute tests>>=
   call test (process_configurations_1, "process_configurations_1", &
        "test processes", &
        u, results)
 <<Process configurations: test declarations>>=
   public :: process_configurations_1
 <<Process configurations: tests>>=
   subroutine process_configurations_1 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: process_configurations_1"
     write (u, "(A)")  "*   Purpose: configure test processes"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     write (u, "(A)")  "* Configure processes as prc_test, model Test"
     write (u, "(A)")  "*                     and omega, model QED"
     write (u, *)
 
     call global%set_int (var_str ("process_num_id"), &
          42, is_known = .true.)
     call prepare_test_library (global, var_str ("prc_config_lib_1"), 3)
 
     global%os_data%fc = "Fortran-compiler"
     global%os_data%fcflags = "Fortran-flags"
 
     call global%write_libraries (u)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_configurations_1"
 
   end subroutine process_configurations_1
 
 @ %def process_configurations_1
 @
 \subsubsection{\oMega\ options}
 Slightly extended example where we pass \oMega\ options to the
 library.  The [[prepare_test_library]] contents are spelled out.
 <<Process configurations: execute tests>>=
   call test (process_configurations_2, "process_configurations_2", &
        "omega options", &
        u, results)
 <<Process configurations: test declarations>>=
   public :: process_configurations_2
 <<Process configurations: tests>>=
   subroutine process_configurations_2 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
 
     type(string_t) :: libname
     type(prclib_entry_t), pointer :: lib
     type(string_t) :: prc_name
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     integer :: n_components
     type(process_configuration_t) :: prc_config
 
     write (u, "(A)")  "* Test output: process_configurations_2"
     write (u, "(A)")  "*   Purpose: configure test processes with options"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
 
     write (u, "(A)")  "* Configure processes as omega, model QED"
     write (u, *)
 
     libname = "prc_config_lib_2"
 
     allocate (lib)
     call lib%init (libname)
     call global%add_prclib (lib)
 
     call global%select_model (var_str ("QED"))
 
     prc_name = "prc_config_c"
     n_components = 2
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("e+"), var_str ("e-")]
     prt_out = [var_str ("m+"), var_str ("m-")]
 
     call global%set_string (var_str ("$method"),&
          var_str ("omega"), is_known = .true.)
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     call prc_config%init (prc_name, size (prt_in), n_components, &
          global%model, global%var_list)
 
     call global%set_log (var_str ("?report_progress"), &
          .true., is_known = .true.)
     call prc_config%setup_component (1, &
          new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list)
 
     call global%set_log (var_str ("?report_progress"), &
          .false., is_known = .true.)
     call global%set_log (var_str ("?omega_openmp"), &
          .true., is_known = .true.)
     call global%set_string (var_str ("$restrictions"),&
          var_str ("3+4~A"), is_known = .true.)
     call global%set_string (var_str ("$omega_flags"), &
          var_str ("-fusion:progress_file omega_prc_config.log"), &
          is_known = .true.)
     call prc_config%setup_component (2, &
          new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list)
 
     call prc_config%record (global)
 
     deallocate (prt_in, prt_out)
 
     global%os_data%fc = "Fortran-compiler"
     global%os_data%fcflags = "Fortran-flags"
 
     call global%write_vars (u, [ &
          var_str ("$model_name"), &
          var_str ("$method"), &
          var_str ("?report_progress"), &
          var_str ("$restrictions"), &
          var_str ("$omega_flags")])
     write (u, "(A)")
     call global%write_libraries (u)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_configurations_2"
 
   end subroutine process_configurations_2
 
 @ %def process_configurations_2
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Compilation}
 This module manages compilation and loading of of process libraries.  It is
 needed as a separate module because integration depends on it.
 <<[[compilations.f90]]>>=
 <<File header>>
 
 module compilations
 
 <<Use strings>>
   use io_units
   use system_defs, only: TAB
   use diagnostics
   use os_interface
   use variables, only: var_list_t
   use model_data
   use process_libraries
   use prclib_stacks
   use rt_data
 
 <<Standard module head>>
 
 <<Compilations: public>>
 
 <<Compilations: types>>
 
 <<Compilations: parameters>>
 
 contains
 
 <<Compilations: procedures>>
 
 end module compilations
 @ %def compilations
 @
 \subsection{The data type}
 The compilation item handles the compilation and loading of a single
 process library.
 <<Compilations: public>>=
   public :: compilation_item_t
 <<Compilations: types>>=
   type :: compilation_item_t
      private
      type(string_t) :: libname
      type(string_t) :: static_external_tag
      type(process_library_t), pointer :: lib => null ()
      logical :: recompile_library = .false.
      logical :: verbose = .false.
      logical :: use_workspace = .false.
      type(string_t) :: workspace
    contains
    <<Compilations: compilation item: TBP>>
   end type compilation_item_t
 
 @ %def compilation_item_t
 @ Initialize.
 
 Set flags and global properties of the library.  Establish the workspace name,
 if defined.
 <<Compilations: compilation item: TBP>>=
   procedure :: init => compilation_item_init
 <<Compilations: procedures>>=
   subroutine compilation_item_init (comp, libname, stack, var_list)
     class(compilation_item_t), intent(out) :: comp
     type(string_t), intent(in) :: libname
     type(prclib_stack_t), intent(inout) :: stack
     type(var_list_t), intent(in) :: var_list
     comp%libname = libname
     comp%lib => stack%get_library_ptr (comp%libname)
     if (.not. associated (comp%lib)) then
        call msg_fatal ("Process library '" // char (comp%libname) &
             // "' has not been declared.")
     end if
     comp%recompile_library = &
          var_list%get_lval (var_str ("?recompile_library"))
     comp%verbose = &
          var_list%get_lval (var_str ("?me_verbose"))
     comp%use_workspace = &
          var_list%is_known (var_str ("$compile_workspace"))
     if (comp%use_workspace) then
        comp%workspace = &
             var_list%get_sval (var_str ("$compile_workspace"))
        if (comp%workspace == "")  comp%use_workspace = .false.
     else
        comp%workspace = ""
     end if
   end subroutine compilation_item_init
 
 @ %def compilation_item_init
 @ Compile the current library.  The [[force]] flag has the
 effect that we first delete any previous files, as far as accessible
 by the current makefile.  It also guarantees that previous files not
 accessible by a makefile will be overwritten.
 <<Compilations: compilation item: TBP>>=
   procedure :: compile => compilation_item_compile
 <<Compilations: procedures>>=
   subroutine compilation_item_compile (comp, model, os_data, force, recompile)
     class(compilation_item_t), intent(inout) :: comp
     class(model_data_t), intent(in), target :: model
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: force, recompile
     if (associated (comp%lib)) then
        if (comp%use_workspace)  call setup_workspace (comp%workspace, os_data)
        call msg_message ("Process library '" &
             // char (comp%libname) // "': compiling ...")
        call comp%lib%configure (os_data)
        if (signal_is_pending ())  return
        call comp%lib%compute_md5sum (model)
        call comp%lib%write_makefile &
             (os_data, force, verbose=comp%verbose, workspace=comp%workspace)
        if (signal_is_pending ())  return
        if (force) then
           call comp%lib%clean &
                (os_data, distclean = .false., workspace=comp%workspace)
           if (signal_is_pending ())  return
        end if
        call comp%lib%write_driver (force, workspace=comp%workspace)
        if (signal_is_pending ())  return
        if (recompile) then
           call comp%lib%load &
                (os_data, keep_old_source = .true., workspace=comp%workspace)
           if (signal_is_pending ())  return
        end if
        call comp%lib%update_status (os_data, workspace=comp%workspace)
     end if
   end subroutine compilation_item_compile
 
 @ %def compilation_item_compile
 @ The workspace directory is created if it does not exist.  (Applies only if
 the use has set the workspace directory.)
 <<Compilations: parameters>>=
   character(*), parameter :: ALLOWED_IN_DIRNAME = &
        "abcdefghijklmnopqrstuvwxyz&
        &ABCDEFGHIJKLMNOPQRSTUVWXYZ&
        &1234567890&
        &.,_-+="
 @ %def ALLOWED_IN_DIRNAME
 <<Compilations: procedures>>=
   subroutine setup_workspace (workspace, os_data)
     type(string_t), intent(in) :: workspace
     type(os_data_t), intent(in) :: os_data
     if (verify (workspace, ALLOWED_IN_DIRNAME) == 0) then
        call msg_message ("Compile: preparing workspace directory '" &
             // char (workspace) // "'")
        call os_system_call ("mkdir -p '" // workspace // "'")
     else
        call msg_fatal ("compile: workspace name '" &
             // char (workspace) // "' contains illegal characters")
     end if
   end subroutine setup_workspace
 
 @ %def setup_workspace
 @ Load the current library, just after compiling it.
 <<Compilations: compilation item: TBP>>=
   procedure :: load => compilation_item_load
 <<Compilations: procedures>>=
   subroutine compilation_item_load (comp, os_data)
     class(compilation_item_t), intent(inout) :: comp
     type(os_data_t), intent(in) :: os_data
     if (associated (comp%lib)) then
        call comp%lib%load (os_data, workspace=comp%workspace)
     end if
   end subroutine compilation_item_load
 
 @ %def compilation_item_load
 @ Message as a separate call:
 <<Compilations: compilation item: TBP>>=
   procedure :: success => compilation_item_success
 <<Compilations: procedures>>=
   subroutine compilation_item_success (comp)
     class(compilation_item_t), intent(in) :: comp
     if (associated (comp%lib)) then
        call msg_message ("Process library '" // char (comp%libname) &
             // "': ... success.")
     else
        call msg_fatal ("Process library '" // char (comp%libname) &
             // "': ... failure.")
     end if
   end subroutine compilation_item_success
 
 @ %def compilation_item_success
 @ %def compilation_item_failure
 @
 \subsection{API for library compilation and loading}
 This is a shorthand for compiling and loading a single library.  The
 [[compilation_item]] object is used only internally.
 
 The [[global]] data set may actually be local to the caller.  The
 compilation affects the library specified by its name if it is on the
 stack, but it does not reset the currently selected library.
 <<Compilations: public>>=
   public :: compile_library
 <<Compilations: procedures>>=
   subroutine compile_library (libname, global)
     type(string_t), intent(in) :: libname
     type(rt_data_t), intent(inout), target :: global
     type(compilation_item_t) :: comp
     logical :: force, recompile
     force = &
          global%var_list%get_lval (var_str ("?rebuild_library"))
     recompile = &
          global%var_list%get_lval (var_str ("?recompile_library"))
     if (associated (global%model)) then
        call comp%init (libname, global%prclib_stack, global%var_list)
        call comp%compile (global%model, global%os_data, force, recompile)
        if (signal_is_pending ())  return
        call comp%load (global%os_data)
        if (signal_is_pending ())  return
     else
        call msg_fatal ("Process library compilation: " &
             // " model is undefined.")
     end if
     call comp%success ()
   end subroutine compile_library
 
 @ %def compile_library
 @
 \subsection{Compiling static executable}
 This object handles the creation of a static executable which should
 contain a set of static process libraries.
 <<Compilations: public>>=
   public :: compilation_t
 <<Compilations: types>>=
   type :: compilation_t
      private
      type(string_t) :: exe_name
      type(string_t), dimension(:), allocatable :: lib_name
    contains
    <<Compilations: compilation: TBP>>
   end type compilation_t
 
 @ %def compilation_t
 @ Output.
 <<Compilations: compilation: TBP>>=
   procedure :: write => compilation_write
 <<Compilations: procedures>>=
   subroutine compilation_write (object, unit)
     class(compilation_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Compilation object:"
     write (u, "(3x,3A)")  "executable        = '", &
          char (object%exe_name), "'"
     write (u, "(3x,A)", advance="no")  "process libraries ="
     do i = 1, size (object%lib_name)
        write (u, "(1x,3A)", advance="no")  "'", char (object%lib_name(i)), "'"
     end do
     write (u, *)
   end subroutine compilation_write
 
 @ %def compilation_write
 @ Initialize: we know the names of the executable and of the libraries.
 Optionally, we may provide a workspace directory.
 <<Compilations: compilation: TBP>>=
   procedure :: init => compilation_init
 <<Compilations: procedures>>=
   subroutine compilation_init (compilation, exe_name, lib_name)
     class(compilation_t), intent(out) :: compilation
     type(string_t), intent(in) :: exe_name
     type(string_t), dimension(:), intent(in) :: lib_name
     compilation%exe_name = exe_name
     allocate (compilation%lib_name (size (lib_name)))
     compilation%lib_name = lib_name
   end subroutine compilation_init
 
 @ %def compilation_init
 @ Write the dispatcher subroutine for the compiled libraries.  Also
 write a subroutine which returns the names of the compiled libraries.
 <<Compilations: compilation: TBP>>=
   procedure :: write_dispatcher => compilation_write_dispatcher
 <<Compilations: procedures>>=
   subroutine compilation_write_dispatcher (compilation)
     class(compilation_t), intent(in) :: compilation
     type(string_t) :: file
     integer :: u, i
     file = compilation%exe_name // "_prclib_dispatcher.f90"
     call msg_message ("Static executable '" // char (compilation%exe_name) &
          // "': writing library dispatcher")
     u = free_unit ()
     open (u, file = char (file), status="replace", action="write")
     write (u, "(3A)")  "! Whizard: process libraries for executable '", &
          char (compilation%exe_name), "'"
     write (u, "(A)")  "! Automatically generated file, do not edit"
     write (u, "(A)")  "subroutine dispatch_prclib_static " // &
          "(driver, basename, modellibs_ldflags)"
     write (u, "(A)")  "  use iso_varying_string, string_t => varying_string"
     write (u, "(A)")  "  use prclib_interfaces"
     do i = 1, size (compilation%lib_name)
        associate (lib_name => compilation%lib_name(i))
          write (u, "(A)")  "  use " // char (lib_name) // "_driver"
        end associate
     end do
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  class(prclib_driver_t), intent(inout), allocatable &
          &:: driver"
     write (u, "(A)")  "  type(string_t), intent(in) :: basename"
     write (u, "(A)")  "  logical, intent(in), optional :: " // &
          "modellibs_ldflags"
     write (u, "(A)")  "  select case (char (basename))"
     do i = 1, size (compilation%lib_name)
        associate (lib_name => compilation%lib_name(i))
          write (u, "(3A)")  "  case ('", char (lib_name), "')"
          write (u, "(3A)")  "     allocate (", char (lib_name), "_driver_t &
               &:: driver)"
        end associate
     end do
     write (u, "(A)")  "  end select"
     write (u, "(A)")  "end subroutine dispatch_prclib_static"
     write (u, *)
     write (u, "(A)")  "subroutine get_prclib_static (libname)"
     write (u, "(A)")  "  use iso_varying_string, string_t => varying_string"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  type(string_t), dimension(:), intent(inout), &
          &allocatable :: libname"
     write (u, "(A,I0,A)")  "  allocate (libname (", &
          size (compilation%lib_name), "))"
     do i = 1, size (compilation%lib_name)
        associate (lib_name => compilation%lib_name(i))
          write (u, "(A,I0,A,A,A)")  "  libname(", i, ") = '", &
               char (lib_name), "'"
        end associate
     end do
     write (u, "(A)")  "end subroutine get_prclib_static"
     close (u)
   end subroutine compilation_write_dispatcher
 
 @ %def compilation_write_dispatcher
 @ Write the Makefile subroutine for the compiled libraries.
 <<Compilations: compilation: TBP>>=
   procedure :: write_makefile => compilation_write_makefile
 <<Compilations: procedures>>=
   subroutine compilation_write_makefile &
        (compilation, os_data, ext_libtag, verbose)
     class(compilation_t), intent(in) :: compilation
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: verbose
     type(string_t), intent(in), optional :: ext_libtag
     type(string_t) :: file, ext_tag
     integer :: u, i
     if (present (ext_libtag)) then
        ext_tag = ext_libtag
     else
        ext_tag = ""
     end if
     file = compilation%exe_name // ".makefile"
     call msg_message ("Static executable '" // char (compilation%exe_name) &
          // "': writing makefile")
     u = free_unit ()
     open (u, file = char (file), status="replace", action="write")
     write (u, "(3A)")  "# WHIZARD: Makefile for executable '", &
          char (compilation%exe_name), "'"
     write (u, "(A)")  "# Automatically generated file, do not edit"
     write (u, "(A)") ""
     write (u, "(A)") "# Executable name"
     write (u, "(A)") "EXE = " // char (compilation%exe_name)
     write (u, "(A)") ""
     write (u, "(A)") "# Compiler"
     write (u, "(A)") "FC = " // char (os_data%fc)
     write (u, "(A)") ""
     write (u, "(A)") "# Included libraries"
     write (u, "(A)") "FCINCL = " // char (os_data%whizard_includes)
     write (u, "(A)") ""
     write (u, "(A)") "# Compiler flags"
     write (u, "(A)") "FCFLAGS = " // char (os_data%fcflags)
     write (u, "(A)") "LDFLAGS = " // char (os_data%ldflags)
     write (u, "(A)") "LDFLAGS_STATIC = " // char (os_data%ldflags_static)
     write (u, "(A)") "LDFLAGS_HEPMC = " // char (os_data%ldflags_hepmc)
     write (u, "(A)") "LDFLAGS_LCIO = " // char (os_data%ldflags_lcio)
     write (u, "(A)") "LDFLAGS_HOPPET = " // char (os_data%ldflags_hoppet)
     write (u, "(A)") "LDFLAGS_LOOPTOOLS = " // char (os_data%ldflags_looptools)
     write (u, "(A)") "LDWHIZARD = " // char (os_data%whizard_ldflags)
     write (u, "(A)") ""
     write (u, "(A)") "# Libtool"
     write (u, "(A)") "LIBTOOL = " // char (os_data%whizard_libtool)
     if (verbose) then
        write (u, "(A)") "FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile"
        write (u, "(A)") "LINK = $(LIBTOOL) --tag=FC --mode=link"
     else
        write (u, "(A)") "FCOMPILE = @$(LIBTOOL) --silent --tag=FC --mode=compile"
        write (u, "(A)") "LINK = @$(LIBTOOL) --silent --tag=FC --mode=link"
     end if
     write (u, "(A)") ""
     write (u, "(A)") "# Compile commands (default)"
     write (u, "(A)") "LTFCOMPILE = $(FCOMPILE) $(FC) -c $(FCINCL) $(FCFLAGS)"
     write (u, "(A)") ""
     write (u, "(A)") "# Default target"
     write (u, "(A)") "all: link"
     write (u, "(A)") ""
     write (u, "(A)") "# Libraries"
     do i = 1, size (compilation%lib_name)
        associate (lib_name => compilation%lib_name(i))
          write (u, "(A)") "LIBRARIES += " // char (lib_name) // ".la"
          write (u, "(A)") char (lib_name) // ".la:"
          write (u, "(A)") TAB // "$(MAKE) -f " // char (lib_name) // ".makefile"
        end associate
     end do
     write (u, "(A)") ""
     write (u, "(A)") "# Library dispatcher"
     write (u, "(A)") "DISP = $(EXE)_prclib_dispatcher"
     write (u, "(A)") "$(DISP).lo: $(DISP).f90 $(LIBRARIES)"
     if (.not. verbose) then
        write (u, "(A)")  TAB // '@echo  "  FC       " $@'
     end if
     write (u, "(A)") TAB // "$(LTFCOMPILE) $<"
     write (u, "(A)") ""
     write (u, "(A)") "# Executable"
     write (u, "(A)") "$(EXE): $(DISP).lo $(LIBRARIES)"
     if (.not. verbose) then
        write (u, "(A)")  TAB // '@echo  "  FCLD     " $@'
     end if
     write (u, "(A)") TAB // "$(LINK) $(FC) -static $(FCFLAGS) \"
     write (u, "(A)") TAB // "   $(LDWHIZARD) $(LDFLAGS) \"
     write (u, "(A)") TAB // "   -o $(EXE) $^ \"
     write (u, "(A)") TAB // "   $(LDFLAGS_HEPMC) $(LDFLAGS_LCIO) $(LDFLAGS_HOPPET) \"
     write (u, "(A)") TAB // "   $(LDFLAGS_LOOPTOOLS) $(LDFLAGS_STATIC)" // char (ext_tag)
     write (u, "(A)") ""
     write (u, "(A)") "# Main targets"
     write (u, "(A)") "link: compile $(EXE)"
     write (u, "(A)") "compile: $(LIBRARIES) $(DISP).lo"
     write (u, "(A)") ".PHONY: link compile"
     write (u, "(A)") ""
     write (u, "(A)") "# Cleanup targets"
     write (u, "(A)") "clean-exe:"
     write (u, "(A)") TAB // "rm -f $(EXE)"
     write (u, "(A)") "clean-objects:"
     write (u, "(A)") TAB // "rm -f $(DISP).lo"
     write (u, "(A)") "clean-source:"
     write (u, "(A)") TAB // "rm -f $(DISP).f90"
     write (u, "(A)") "clean-makefile:"
     write (u, "(A)") TAB // "rm -f $(EXE).makefile"
     write (u, "(A)") ""
     write (u, "(A)") "clean: clean-exe clean-objects clean-source"
     write (u, "(A)") "distclean: clean clean-makefile"
     write (u, "(A)") ".PHONY: clean distclean"
     close (u)
   end subroutine compilation_write_makefile
 
 @ %def compilation_write_makefile
 @ Compile the dispatcher source code.
 <<Compilations: compilation: TBP>>=
   procedure :: make_compile => compilation_make_compile
 <<Compilations: procedures>>=
   subroutine compilation_make_compile (compilation, os_data)
     class(compilation_t), intent(in) :: compilation
     type(os_data_t), intent(in) :: os_data
     call os_system_call ("make compile " // os_data%makeflags &
          // " -f " // compilation%exe_name // ".makefile")
   end subroutine compilation_make_compile
 
 @ %def compilation_make_compile
 @ Link the dispatcher together with all matrix-element code and the
 \whizard\ and \oMega\ main libraries, to generate a static executable.
 <<Compilations: compilation: TBP>>=
   procedure :: make_link => compilation_make_link
 <<Compilations: procedures>>=
   subroutine compilation_make_link (compilation, os_data)
     class(compilation_t), intent(in) :: compilation
     type(os_data_t), intent(in) :: os_data
     call os_system_call ("make link " // os_data%makeflags &
          // " -f " // compilation%exe_name // ".makefile")
   end subroutine compilation_make_link
 
 @ %def compilation_make_link
 @ Cleanup.
 <<Compilations: compilation: TBP>>=
   procedure :: make_clean_exe => compilation_make_clean_exe
 <<Compilations: procedures>>=
   subroutine compilation_make_clean_exe (compilation, os_data)
     class(compilation_t), intent(in) :: compilation
     type(os_data_t), intent(in) :: os_data
     call os_system_call ("make clean-exe " // os_data%makeflags &
          // " -f " // compilation%exe_name // ".makefile")
   end subroutine compilation_make_clean_exe
 
 @ %def compilation_make_clean_exe
 @
 \subsection{API for executable compilation}
 This is a shorthand for compiling and loading an executable, including
 the enclosed libraries.  The [[compilation]] object is used only internally.
 
 The [[global]] data set may actually be local to the caller.  The
 compilation affects the library specified by its name if it is on the
 stack, but it does not reset the currently selected library.
 <<Compilations: public>>=
   public :: compile_executable
 <<Compilations: procedures>>=
   subroutine compile_executable (exename, libname, global)
     type(string_t), intent(in) :: exename
     type(string_t), dimension(:), intent(in) :: libname
     type(rt_data_t), intent(inout), target :: global
     type(compilation_t) :: compilation
     type(compilation_item_t) :: item
     type(string_t) :: ext_libtag
     logical :: force, recompile, verbose
     integer :: i
     ext_libtag = ""
     force = &
          global%var_list%get_lval (var_str ("?rebuild_library"))
     recompile = &
          global%var_list%get_lval (var_str ("?recompile_library"))
     verbose = &
          global%var_list%get_lval (var_str ("?me_verbose"))
     call compilation%init (exename, [libname])
     if (signal_is_pending ())  return
     call compilation%write_dispatcher ()
     if (signal_is_pending ())  return
     do i = 1, size (libname)
        call item%init (libname(i), global%prclib_stack, global%var_list)
        call item%compile (global%model, global%os_data, &
             force=force, recompile=recompile)
        ext_libtag = "" // item%lib%get_static_modelname (global%os_data)
        if (signal_is_pending ())  return
        call item%success ()
     end do
     call compilation%write_makefile &
          (global%os_data, ext_libtag=ext_libtag, verbose=verbose)
     if (signal_is_pending ())  return
     call compilation%make_compile (global%os_data)
     if (signal_is_pending ())  return
     call compilation%make_link (global%os_data)
   end subroutine compile_executable
 
 @ %def compile_executable
 @
 \subsection{Unit Tests}
 Test module, followed by the stand-alone unit-test procedures.
 <<[[compilations_ut.f90]]>>=
 <<File header>>
 
 module compilations_ut
   use unit_tests
   use compilations_uti
 
 <<Standard module head>>
 
 <<Compilations: public test>>
 
 contains
 
 <<Compilations: test driver>>
 
 end module compilations_ut
 @ %def compilations_ut
 @
 <<[[compilations_uti.f90]]>>=
 <<File header>>
 
 module compilations_uti
 
 <<Use strings>>
   use io_units
   use models
   use rt_data
   use process_configurations_ut, only: prepare_test_library
 
   use compilations
 
 <<Standard module head>>
 
 <<Compilations: test declarations>>
 
 contains
 
 <<Compilations: tests>>
 
 end module compilations_uti
 
 @ %def compilations_uti
 @ API: driver for the unit tests below.
 <<Compilations: public test>>=
   public :: compilations_test
 <<Compilations: test driver>>=
   subroutine compilations_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Compilations: execute tests>>
 end subroutine compilations_test
 
 @ %def compilations_test
 @
 \subsubsection{Intrinsic Matrix Element}
 Compile an intrinsic test matrix element ([[prc_test]] type).
 
 Note: In this and the following test, we reset the Fortran compiler and flag
 variables immediately before they are printed, so the test is portable.
 <<Compilations: execute tests>>=
   call test (compilations_1, "compilations_1", &
        "intrinsic test processes", &
        u, results)
 <<Compilations: test declarations>>=
   public :: compilations_1
 <<Compilations: tests>>=
   subroutine compilations_1 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: compilations_1"
     write (u, "(A)")  "*   Purpose: configure and compile test process"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
 
     libname = "compilation_1"
     procname = "prc_comp_1"
     call prepare_test_library (global, libname, 1, [procname])
 
     call compile_library (libname, global)
 
     call global%write_libraries (u)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: compilations_1"
 
   end subroutine compilations_1
 
 @ %def compilations_1
 @
 \subsubsection{External Matrix Element}
 Compile an external test matrix element ([[omega]] type)
 <<Compilations: execute tests>>=
   call test (compilations_2, "compilations_2", &
        "external process (omega)", &
        u, results)
 <<Compilations: test declarations>>=
   public :: compilations_2
 <<Compilations: tests>>=
   subroutine compilations_2 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: compilations_2"
     write (u, "(A)")  "*   Purpose: configure and compile test process"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     libname = "compilation_2"
     procname = "prc_comp_2"
     call prepare_test_library (global, libname, 2, [procname,procname])
 
     call compile_library (libname, global)
 
     call global%write_libraries (u, libpath = .false.)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: compilations_2"
 
   end subroutine compilations_2
 
 @ %def compilations_2
 @
 \subsubsection{External Matrix Element}
 Compile an external test matrix element ([[omega]] type) and
 create driver files for a static executable.
 <<Compilations: execute tests>>=
   call test (compilations_3, "compilations_3", &
        "static executable: driver", &
        u, results)
 <<Compilations: test declarations>>=
   public :: compilations_3
 <<Compilations: tests>>=
   subroutine compilations_3 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname, exename
     type(rt_data_t), target :: global
     type(compilation_t) :: compilation
     integer :: u_file
     character(80) :: buffer
 
     write (u, "(A)")  "* Test output: compilations_3"
     write (u, "(A)")  "*   Purpose: make static executable"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize library"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     libname = "compilations_3_lib"
     procname = "prc_comp_3"
     exename = "compilations_3"
 
     call prepare_test_library (global, libname, 2, [procname,procname])
 
     call compilation%init (exename, [libname])
     call compilation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write dispatcher"
     write (u, "(A)")
 
     call compilation%write_dispatcher ()
 
     u_file = free_unit ()
     open (u_file, file = char (exename) // "_prclib_dispatcher.f90", &
          status = "old", action = "read")
     do
        read (u_file, "(A)", end = 1)  buffer
        write (u, "(A)")  trim (buffer)
     end do
 1   close (u_file)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write Makefile"
     write (u, "(A)")
 
     associate (os_data => global%os_data)
       os_data%fc = "fortran-compiler"
       os_data%whizard_includes = "my-includes"
       os_data%fcflags = "my-fcflags"
       os_data%ldflags = "my-ldflags"
       os_data%ldflags_static = "my-ldflags-static"
       os_data%ldflags_hepmc = "my-ldflags-hepmc"
       os_data%ldflags_lcio = "my-ldflags-lcio"
       os_data%ldflags_hoppet = "my-ldflags-hoppet"
       os_data%ldflags_looptools = "my-ldflags-looptools"
       os_data%whizard_ldflags = "my-ldwhizard"
       os_data%whizard_libtool = "my-libtool"
     end associate
 
     call compilation%write_makefile (global%os_data, verbose = .true.)
 
     open (u_file, file = char (exename) // ".makefile", &
          status = "old", action = "read")
     do
        read (u_file, "(A)", end = 2)  buffer
        write (u, "(A)")  trim (buffer)
     end do
 2   close (u_file)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: compilations_3"
 
   end subroutine compilations_3
 
 @ %def compilations_3
 @
 \subsection{Test static build}
 The tests for building a static executable are separate, since they
 should be skipped if the \whizard\ build itself has static libraries
 disabled.
 <<Compilations: public test>>=
   public :: compilations_static_test
 <<Compilations: test driver>>=
   subroutine compilations_static_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Compilations: static tests>>
 end subroutine compilations_static_test
 
 @ %def compilations_static_test
 @
 \subsubsection{External Matrix Element}
 Compile an external test matrix element ([[omega]] type) and
 incorporate this in a new static WHIZARD executable.
 <<Compilations: static tests>>=
   call test (compilations_static_1, "compilations_static_1", &
        "static executable: compilation", &
        u, results)
 <<Compilations: test declarations>>=
   public :: compilations_static_1
 <<Compilations: tests>>=
   subroutine compilations_static_1 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname, exename
     type(rt_data_t), target :: global
     type(compilation_item_t) :: item
     type(compilation_t) :: compilation
     logical :: exist
 
     write (u, "(A)")  "* Test output: compilations_static_1"
     write (u, "(A)")  "*   Purpose: make static executable"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize library"
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     libname = "compilations_static_1_lib"
     procname = "prc_comp_stat_1"
     exename = "compilations_static_1"
 
     call prepare_test_library (global, libname, 2, [procname,procname])
 
     call compilation%init (exename, [libname])
 
     write (u, "(A)")
     write (u, "(A)")  "* Write dispatcher"
 
     call compilation%write_dispatcher ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Write Makefile"
 
     call compilation%write_makefile (global%os_data, verbose = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build libraries"
 
     call item%init (libname, global%prclib_stack, global%var_list)
     call item%compile &
          (global%model, global%os_data, force=.true., recompile=.false.)
     call item%success ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Check executable (should be absent)"
     write (u, "(A)")
 
     call compilation%make_clean_exe (global%os_data)
     inquire (file = char (exename), exist = exist)
     write (u, "(A,A,L1)")  char (exename), " exists = ", exist
 
     write (u, "(A)")
     write (u, "(A)")  "* Build executable"
     write (u, "(A)")
 
     call compilation%make_compile (global%os_data)
     call compilation%make_link (global%os_data)
 
     write (u, "(A)")  "* Check executable (should be present)"
     write (u, "(A)")
 
     inquire (file = char (exename), exist = exist)
     write (u, "(A,A,L1)")  char (exename), " exists = ", exist
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call compilation%make_clean_exe (global%os_data)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: compilations_static_1"
 
   end subroutine compilations_static_1
 
 @ %def compilations_static_1
 @
 \subsubsection{External Matrix Element}
 Compile an external test matrix element ([[omega]] type) and
 incorporate this in a new static WHIZARD executable.  In this version,
 we use the wrapper [[compile_executable]] procedure.
 <<Compilations: static tests>>=
   call test (compilations_static_2, "compilations_static_2", &
        "static executable: shortcut", &
        u, results)
 <<Compilations: test declarations>>=
   public :: compilations_static_2
 <<Compilations: tests>>=
   subroutine compilations_static_2 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname, exename
     type(rt_data_t), target :: global
     logical :: exist
     integer :: u_file
 
     write (u, "(A)")  "* Test output: compilations_static_2"
     write (u, "(A)")  "*   Purpose: make static executable"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize library and compile"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     libname = "compilations_static_2_lib"
     procname = "prc_comp_stat_2"
     exename = "compilations_static_2"
 
     call prepare_test_library (global, libname, 2, [procname,procname])
 
     call compile_executable (exename, [libname], global)
 
     write (u, "(A)")  "* Check executable (should be present)"
     write (u, "(A)")
 
     inquire (file = char (exename), exist = exist)
     write (u, "(A,A,L1)")  char (exename), " exists = ", exist
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     u_file = free_unit ()
     open (u_file, file = char (exename), status = "old", action = "write")
     close (u_file, status = "delete")
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: compilations_static_2"
 
   end subroutine compilations_static_2
 
 @ %def compilations_static_2
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Integration}
 This module manages phase space setup, matrix-element evaluation and
 integration, as far as it is not done by lower-level routines, in particular
 in the [[processes]] module.
 <<[[integrations.f90]]>>=
 <<File header>>
 
 module integrations
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use diagnostics
   use os_interface
   use cputime
   use sm_qcd
   use physics_defs
   use model_data
   use pdg_arrays
   use variables, only: var_list_t
   use eval_trees
   use sf_mappings
   use sf_base
   use phs_base
   use rng_base
   use mci_base
   use process_libraries
   use prc_core
   use process_config, only: COMP_MASTER, COMP_REAL_FIN, &
        COMP_MISMATCH, COMP_PDF, COMP_REAL, COMP_SUB, COMP_VIRT, &
        COMP_REAL_SING
   use process
   use pcm_base, only: pcm_t
   use instances
   use process_stacks
   use models
   use iterations
   use rt_data
 
   use dispatch_me_methods, only: dispatch_core
   use dispatch_beams, only: dispatch_qcd, sf_prop_t, dispatch_sf_config
   use dispatch_phase_space, only: dispatch_sf_channels
   use dispatch_phase_space, only: dispatch_phs
   use dispatch_mci, only: dispatch_mci_s, setup_grid_path
   use dispatch_transforms, only: dispatch_evt_shower_hook
 
   use compilations, only: compile_library
 
   use dispatch_fks, only: dispatch_fks_s
   use nlo_data
 <<Use mpi f08>>
 
 <<Standard module head>>
 
 <<Integrations: public>>
 
 <<Integrations: types>>
 
 contains
 
 <<Integrations: procedures>>
 
 end module integrations
 @ %def integrations
 @
 \subsection{The integration type}
 This type holds all relevant data, the integration methods operates on this.
 In contrast to the [[simulation_t]] introduced later, the [[integration_t]]
 applies to a single process.
 <<Integrations: public>>=
   public :: integration_t
 <<Integrations: types>>=
   type :: integration_t
     private
     type(string_t) :: process_id
     type(string_t) :: run_id
     type(process_t), pointer :: process => null ()
     logical :: rebuild_phs = .false.
     logical :: ignore_phs_mismatch = .false.
     logical :: phs_only = .false.
     logical :: process_has_me = .true.
     integer :: n_calls_test = 0
     logical :: vis_history = .true.
     type(string_t) :: history_filename
     type(string_t) :: log_filename
     type(helicity_selection_t) :: helicity_selection
     logical :: use_color_factors = .false.
     logical :: has_beam_pol = .false.
     logical :: combined_integration = .false.
     type(iteration_multipliers_t) :: iteration_multipliers
     type(nlo_settings_t) :: nlo_settings
    contains
    <<Integrations: integration: TBP>>
   end type integration_t
 
 @ %def integration_t
 @
 @
 \subsection{Initialization}
 Initialization, first part: Create a process entry.
 Push it on the stack if the [[global]] environment is supplied.
 <<Integrations: integration: TBP>>=
   procedure :: create_process => integration_create_process
 <<Integrations: procedures>>=
   subroutine integration_create_process (intg, process_id, global)
     class(integration_t), intent(out) :: intg
     type(rt_data_t), intent(inout), optional, target :: global
     type(string_t), intent(in) :: process_id
     type(process_entry_t), pointer :: process_entry
     if (debug_on) call msg_debug (D_CORE, "integration_create_process")
     intg%process_id = process_id
     if (present (global)) then
        allocate (process_entry)
        intg%process => process_entry%process_t
        call global%process_stack%push (process_entry)
     else
        allocate (process_t :: intg%process)
     end if
   end subroutine integration_create_process
 
 @ %def integration_create_process
 @ Initialization, second part: Initialize the process object, using the local
 environment.  We allocate a RNG factory and a QCD object.
 We also fetch a pointer to the model that the process uses.  The
 process initializer will create a snapshot of that model.
 
 This procedure
 does not modify the [[local]] stack directly.  The intent(inout) attribute for
 the [[local]] data set is due to the random generator seed which may be
 incremented during initialization.
 
 NOTE: Changes to model parameters within the current context are respected
 only if the process model coincides with the current model.  This is the usual
 case.  If not, we read
 the model from the global model library, which has default parameters.  To
 become more flexible, we should implement a local model library which records
 local changes to currently inactive models.
 <<Integrations: integration: TBP>>=
   procedure :: init_process => integration_init_process
 <<Integrations: procedures>>=
   subroutine integration_init_process (intg, local)
     class(integration_t), intent(inout) :: intg
     type(rt_data_t), intent(inout), target :: local
     type(string_t) :: model_name
     type(model_t), pointer :: model
     class(model_data_t), pointer :: model_instance
     type(var_list_t), pointer :: var_list
     if (debug_on) call msg_debug (D_CORE, "integration_init_process")
     if (.not. local%prclib%contains (intg%process_id)) then
        call msg_fatal ("Process '" // char (intg%process_id) // "' not found" &
             // " in library '" // char (local%prclib%get_name ()) // "'")
        return
     end if
     model_name = local%prclib%get_model_name (intg%process_id)
     if (local%get_sval (var_str ("$model_name")) == model_name) then
        model => local%model
     else
        model => local%model_list%get_model_ptr (model_name)
     end if
     var_list => local%get_var_list_ptr ()
     call intg%process%init (intg%process_id, &
          local%prclib, &
          local%os_data, &
          model, &
          var_list, &
          local%beam_structure)
     intg%run_id = intg%process%get_run_id ()
   end subroutine integration_init_process
 
 @ %def integration_init_process
 @ Initialization, third part: complete process configuration.
 <<Integrations: integration: TBP>>=
   procedure :: setup_process => integration_setup_process
 <<Integrations: procedures>>=
   subroutine integration_setup_process (intg, local, verbose, init_only)
     class(integration_t), intent(inout) :: intg
     type(rt_data_t), intent(inout), target :: local
     logical, intent(in), optional :: verbose
     logical, intent(in), optional :: init_only
 
     type(var_list_t), pointer :: var_list
     class(mci_t), allocatable :: mci_template
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_prop_t) :: sf_prop
     type(sf_channel_t), dimension(:), allocatable :: sf_channel
     type(phs_channel_collection_t) :: phs_channel_collection
     logical :: sf_trace
     logical :: verb, initialize_only
     type(string_t) :: sf_string
     type(string_t) :: workspace
 
     verb = .true.;  if (present (verbose))  verb = verbose
 
     initialize_only = .false.
     if (present (init_only))  initialize_only = init_only
 
     call display_init_message (verb)
 
     var_list => local%get_var_list_ptr ()
     call setup_log_and_history ()
 
     associate (process => intg%process)
       call set_intg_parameters (process)
 
       call process%setup_cores (dispatch_core, &
            intg%helicity_selection, intg%use_color_factors, intg%has_beam_pol)
 
       call process%init_phs_config ()
       call process%init_components ()
 
       call process%record_inactive_components ()
       intg%process_has_me = process%has_matrix_element ()
       if (.not. intg%process_has_me) then
          call msg_warning ("Process '" &
               // char (intg%process_id) // "': matrix element vanishes")
       end if
 
       call setup_beams ()
       call setup_structure_functions ()
 
       workspace = var_list%get_sval (var_str ("$integrate_workspace"))
       if (workspace == "") then
          call process%configure_phs &
               (intg%rebuild_phs, &
               intg%ignore_phs_mismatch, &
               intg%combined_integration)
       else
          call setup_grid_path (workspace)
          call process%configure_phs &
               (intg%rebuild_phs, &
               intg%ignore_phs_mismatch, &
               intg%combined_integration, &
               workspace)
       end if
 
       call process%complete_pcm_setup ()
 
       call process%prepare_blha_cores ()
       call process%create_blha_interface ()
       call process%prepare_any_external_code ()
 
       call process%setup_terms (with_beams = intg%has_beam_pol)
       call process%check_masses ()
+      call process%optimize_nlo_singular_regions ()
 
       if (verb) then
          call process%write (screen = .true.)
          call process%print_phs_startup_message ()
       end if
 
       if (intg%process_has_me) then
          if (size (sf_config) > 0) then
             call process%collect_channels (phs_channel_collection)
          else if (.not. initialize_only &
               .and. process%contains_trivial_component ()) then
             call msg_fatal ("Integrate: 2 -> 1 process can't be handled &
                  &with fixed-energy beams")
          end if
          call dispatch_sf_channels &
               (sf_channel, sf_string, sf_prop, phs_channel_collection, &
               local%var_list, local%get_sqrts(), local%beam_structure)
          if (allocated (sf_channel)) then
             if (size (sf_channel) > 0) then
                call process%set_sf_channel (sf_channel)
             end if
          end if
          call phs_channel_collection%final ()
          if (verb)  call process%sf_startup_message (sf_string)
       end if
 
       call process%setup_mci (dispatch_mci_s)
 
       call setup_expressions ()
 
       call process%compute_md5sum ()
     end associate
 
   contains
 
     subroutine setup_log_and_history ()
        if (intg%run_id /= "") then
           intg%history_filename = intg%process_id // "." // intg%run_id &
                // ".history"
           intg%log_filename = intg%process_id // "." // intg%run_id // ".log"
        else
           intg%history_filename = intg%process_id // ".history"
           intg%log_filename = intg%process_id // ".log"
        end if
        intg%vis_history = &
           var_list%get_lval (var_str ("?vis_history"))
     end subroutine setup_log_and_history
 
     subroutine set_intg_parameters (process)
       type(process_t), intent(in) :: process
       intg%n_calls_test = &
            var_list%get_ival (var_str ("n_calls_test"))
       intg%combined_integration = &
            var_list%get_lval (var_str ('?combined_nlo_integration')) &
            .and. process%is_nlo_calculation ()
       intg%use_color_factors = &
            var_list%get_lval (var_str ("?read_color_factors"))
       intg%has_beam_pol = &
            local%beam_structure%has_polarized_beams ()
       intg%helicity_selection = &
            local%get_helicity_selection ()
       intg%rebuild_phs = &
            var_list%get_lval (var_str ("?rebuild_phase_space"))
       intg%ignore_phs_mismatch = &
          .not. var_list%get_lval (var_str ("?check_phs_file"))
       intg%phs_only = &
            var_list%get_lval (var_str ("?phs_only"))
     end subroutine set_intg_parameters
 
     subroutine display_init_message (verb)
       logical, intent(in) :: verb
       if (verb) then
          call msg_message ("Initializing integration for process " &
               // char (intg%process_id) // ":")
          if (intg%run_id /= "") &
               call msg_message ("Run ID = " // '"' // char (intg%run_id) // '"')
       end if
     end subroutine display_init_message
 
     subroutine setup_beams ()
       real(default) :: sqrts
       logical :: decay_rest_frame
       sqrts = local%get_sqrts ()
       decay_rest_frame = &
            var_list%get_lval (var_str ("?decay_rest_frame"))
       if (intg%process_has_me) then
          call intg%process%setup_beams_beam_structure &
               (local%beam_structure, sqrts, decay_rest_frame)
       end if
       if (verb .and. intg%process_has_me) then
          call intg%process%beams_startup_message &
               (beam_structure = local%beam_structure)
       end if
     end subroutine setup_beams
 
     subroutine setup_structure_functions ()
       integer :: n_in
       type(pdg_array_t), dimension(:,:), allocatable :: pdg_prc
       type(string_t) :: sf_trace_file
       if (intg%process_has_me) then
          call intg%process%get_pdg_in (pdg_prc)
       else
          n_in = intg%process%get_n_in ()
          allocate (pdg_prc (n_in, intg%process%get_n_components ()))
          pdg_prc = 0
       end if
       call dispatch_sf_config (sf_config, sf_prop, local%beam_structure, &
            local%get_var_list_ptr (), local%var_list, &
            local%model, local%os_data, local%get_sqrts (), pdg_prc)
 
       sf_trace = &
            var_list%get_lval (var_str ("?sf_trace"))
       sf_trace_file = &
            var_list%get_sval (var_str ("$sf_trace_file"))
       if (sf_trace) then
          call intg%process%init_sf_chain (sf_config, sf_trace_file)
       else
          call intg%process%init_sf_chain (sf_config)
       end if
     end subroutine setup_structure_functions
 
     subroutine setup_expressions ()
       type(eval_tree_factory_t) :: expr_factory
       if (associated (local%pn%cuts_lexpr)) then
          if (verb)  call msg_message ("Applying user-defined cuts.")
          call expr_factory%init (local%pn%cuts_lexpr)
          call intg%process%set_cuts (expr_factory)
       else
          if (verb)  call msg_warning ("No cuts have been defined.")
       end if
       if (associated (local%pn%scale_expr)) then
          if (verb) call msg_message ("Using user-defined general scale.")
          call expr_factory%init (local%pn%scale_expr)
          call intg%process%set_scale (expr_factory)
       end if
       if (associated (local%pn%fac_scale_expr)) then
          if (verb) call msg_message ("Using user-defined factorization scale.")
          call expr_factory%init (local%pn%fac_scale_expr)
          call intg%process%set_fac_scale (expr_factory)
       end if
       if (associated (local%pn%ren_scale_expr)) then
          if (verb) call msg_message ("Using user-defined renormalization scale.")
          call expr_factory%init (local%pn%ren_scale_expr)
          call intg%process%set_ren_scale (expr_factory)
       end if
       if (associated (local%pn%weight_expr)) then
          if (verb) call msg_message ("Using user-defined reweighting factor.")
          call expr_factory%init (local%pn%weight_expr)
          call intg%process%set_weight (expr_factory)
       end if
     end subroutine setup_expressions
   end subroutine integration_setup_process
 
 @ %def integration_setup_process
 @
 \subsection{Integration}
 Integrate: do the final integration.  Here, we do a multi-iteration
 integration.  Again, we skip iterations that are already on file.
 Record the results in the global variable list.
 <<Integrations: integration: TBP>>=
   procedure :: evaluate => integration_evaluate
 <<Integrations: procedures>>=
   subroutine integration_evaluate &
        (intg, process_instance, i_mci, pass, it_list, pacify)
     class(integration_t), intent(inout) :: intg
     type(process_instance_t), intent(inout), target :: process_instance
     integer, intent(in) :: i_mci
     integer, intent(in) :: pass
     type(iterations_list_t), intent(in) :: it_list
     logical, intent(in), optional :: pacify
     integer :: n_calls, n_it
     logical :: adapt_grids, adapt_weights, final
     n_it = it_list%get_n_it (pass)
     n_calls = it_list%get_n_calls (pass)
     adapt_grids = it_list%adapt_grids (pass)
     adapt_weights = it_list%adapt_weights (pass)
     final = pass == it_list%get_n_pass ()
     call process_instance%integrate ( &
          i_mci, n_it, n_calls, adapt_grids, adapt_weights, &
          final, pacify)
   end subroutine integration_evaluate
 
 @ %def integration_evaluate
 @ In case the user has not provided a list of iterations, make a
 reasonable default.  This can depend on the process.  The usual
 approach is to define two distinct passes, one for adaptation and one
 for integration.
 <<Integrations: integration: TBP>>=
   procedure :: make_iterations_list => integration_make_iterations_list
 <<Integrations: procedures>>=
   subroutine integration_make_iterations_list (intg, it_list)
     class(integration_t), intent(in) :: intg
     type(iterations_list_t), intent(out) :: it_list
     integer :: pass, n_pass
     integer, dimension(:), allocatable :: n_it, n_calls
     logical, dimension(:), allocatable :: adapt_grids, adapt_weights
     n_pass = intg%process%get_n_pass_default ()
     allocate (n_it (n_pass), n_calls (n_pass))
     allocate (adapt_grids (n_pass), adapt_weights (n_pass))
     do pass = 1, n_pass
        n_it(pass)          = intg%process%get_n_it_default (pass)
        n_calls(pass)       = intg%process%get_n_calls_default (pass)
        adapt_grids(pass)   = intg%process%adapt_grids_default (pass)
        adapt_weights(pass) = intg%process%adapt_weights_default (pass)
     end do
     call it_list%init (n_it, n_calls, &
          adapt_grids = adapt_grids, adapt_weights = adapt_weights)
   end subroutine integration_make_iterations_list
 
 @ %def integration_make_iterations_list
 @ In NLO calculations, the individual components might scale very differently
 with the number of calls. This especially applies to the real-subtracted
 component, which usually fluctuates more than the Born and virtual
 component, making it a bottleneck of the calculation. Thus, the calculation
 is throttled twice, first by the number of calls for the real component,
 second by the number of surplus calls of computation-intense virtual
 matrix elements. Therefore, we want to set a different number of calls
 for each component, which is done by the subroutine [[integration_apply_call_multipliers]].
 <<Integrations: integration: TBP>>=
   procedure :: init_iteration_multipliers => integration_init_iteration_multipliers
 <<Integrations: procedures>>=
   subroutine integration_init_iteration_multipliers (intg, local)
     class(integration_t), intent(inout) :: intg
     type(rt_data_t), intent(in) :: local
     integer :: n_pass, pass
     type(iterations_list_t) :: it_list
     n_pass = local%it_list%get_n_pass ()
     if (n_pass == 0) then
        call intg%make_iterations_list (it_list)
        n_pass = it_list%get_n_pass ()
     end if
     associate (it_multipliers => intg%iteration_multipliers)
        allocate (it_multipliers%n_calls0 (n_pass))
        do pass = 1, n_pass
           it_multipliers%n_calls0(pass) = local%it_list%get_n_calls (pass)
        end do
        it_multipliers%mult_real = local%var_list%get_rval &
            (var_str ("mult_call_real"))
        it_multipliers%mult_virt = local%var_list%get_rval &
            (var_str ("mult_call_virt"))
        it_multipliers%mult_dglap = local%var_list%get_rval &
            (var_str ("mult_call_dglap"))
     end associate
   end subroutine integration_init_iteration_multipliers
 
 @ %def integration_init_iteration_multipliers
 @
 <<Integrations: integration: TBP>>=
   procedure :: apply_call_multipliers => integration_apply_call_multipliers
 <<Integrations: procedures>>=
   subroutine integration_apply_call_multipliers (intg, n_pass, i_component, it_list)
     class(integration_t), intent(in) :: intg
     integer, intent(in) :: n_pass, i_component
     type(iterations_list_t), intent(inout) :: it_list
     integer :: nlo_type
     integer :: n_calls0, n_calls
     integer :: pass
     real(default) :: multiplier
     nlo_type = intg%process%get_component_nlo_type (i_component)
     do pass = 1, n_pass
        associate (multipliers => intg%iteration_multipliers)
          select case (nlo_type)
          case (NLO_REAL)
             multiplier = multipliers%mult_real
          case (NLO_VIRTUAL)
             multiplier = multipliers%mult_virt
          case (NLO_DGLAP)
             multiplier = multipliers%mult_dglap
          case default
             return
          end select
        end associate
        if (n_pass <= size (intg%iteration_multipliers%n_calls0)) then
           n_calls0 = intg%iteration_multipliers%n_calls0 (pass)
           n_calls = floor (multiplier * n_calls0)
           call it_list%set_n_calls (pass, n_calls)
        end if
     end do
   end subroutine integration_apply_call_multipliers
 
 @ %def integration_apply_call_multipliers
 @
 \subsection{API for integration objects}
 This initializer does everything except assigning cuts/scale/weight
 expressions.
 <<Integrations: integration: TBP>>=
   procedure :: init => integration_init
 <<Integrations: procedures>>=
   subroutine integration_init &
        (intg, process_id, local, global, local_stack, init_only)
     class(integration_t), intent(out) :: intg
     type(string_t), intent(in) :: process_id
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), optional, target :: global
     logical, intent(in), optional :: init_only
     logical, intent(in), optional :: local_stack
     logical :: use_local
     use_local = .false.;  if (present (local_stack))  use_local = local_stack
     if (present (global)) then
        call intg%create_process (process_id, global)
     else if (use_local) then
        call intg%create_process (process_id, local)
     else
        call intg%create_process (process_id)
     end if
     call intg%init_process (local)
     call intg%setup_process (local, init_only = init_only)
     call intg%init_iteration_multipliers (local)
   end subroutine integration_init
 
 @ %def integration_init
 @ Do the integration for a single process, both warmup and final evaluation.
 The [[eff_reset]] flag is to suppress numerical noise in the graphical output
 of the integration history.
 <<Integrations: integration: TBP>>=
   procedure :: integrate => integration_integrate
 <<Integrations: procedures>>=
   subroutine integration_integrate (intg, local, eff_reset)
     class(integration_t), intent(inout) :: intg
     type(rt_data_t), intent(in), target :: local
     logical, intent(in), optional :: eff_reset
     type(string_t) :: log_filename
     type(var_list_t), pointer :: var_list
     type(process_instance_t), allocatable, target :: process_instance
     type(iterations_list_t) :: it_list
     logical :: pacify
     integer :: pass, i_mci, n_mci, n_pass
     integer :: i_component
     integer :: nlo_type
     logical :: display_summed
     logical :: nlo_active
     type(string_t) :: component_output
 
     allocate (process_instance)
     call process_instance%init (intg%process)
 
     var_list => intg%process%get_var_list_ptr ()
     call openmp_set_num_threads_verbose &
          (var_list%get_ival (var_str ("openmp_num_threads")), &
           var_list%get_lval (var_str ("?openmp_logging")))
     pacify = var_list%get_lval (var_str ("?pacify"))
 
     display_summed = .true.
     n_mci = intg%process%get_n_mci ()
     if (n_mci == 1) then
        write (msg_buffer, "(A,A,A)") &
             "Starting integration for process '", &
             char (intg%process%get_id ()), "'"
        call msg_message ()
     end if
 
     call setup_hooks ()
 
     nlo_active = any (intg%process%get_component_nlo_type &
          ([(i_mci, i_mci = 1, n_mci)]) /= BORN)
     do i_mci = 1, n_mci
        i_component = intg%process%get_master_component (i_mci)
        nlo_type = intg%process%get_component_nlo_type (i_component)
        if (intg%process%component_can_be_integrated (i_component)) then
           if (n_mci > 1) then
              if (nlo_active) then
                 if (intg%combined_integration .and. nlo_type == BORN) then
                    component_output = var_str ("Combined")
                 else
                    component_output = component_status (nlo_type)
                 end if
                 write (msg_buffer, "(A,A,A,A,A)") &
                      "Starting integration for process '", &
                      char (intg%process%get_id ()), "' part '", &
                      char (component_output), "'"
              else
                 write (msg_buffer, "(A,A,A,I0)") &
                      "Starting integration for process '", &
                      char (intg%process%get_id ()), "' part ", i_mci
              end if
              call msg_message ()
           end if
           n_pass = local%it_list%get_n_pass ()
           if (n_pass == 0) then
              call msg_message ("Integrate: iterations not specified, &
                   &using default")
              call intg%make_iterations_list (it_list)
              n_pass = it_list%get_n_pass ()
           else
              it_list = local%it_list
           end if
           call intg%apply_call_multipliers (n_pass, i_mci, it_list)
           call msg_message ("Integrate: " // char (it_list%to_string ()))
           do pass = 1, n_pass
              call intg%evaluate (process_instance, i_mci, pass, it_list, pacify)
              if (signal_is_pending ())  return
           end do
           call intg%process%final_integration (i_mci)
           if (intg%vis_history) then
              call intg%process%display_integration_history &
                   (i_mci, intg%history_filename, local%os_data, eff_reset)
           end if
           if (local%logfile == intg%log_filename) then
              if (intg%run_id /= "") then
                 log_filename = intg%process_id // "." // intg%run_id // &
                      ".var.log"
              else
                 log_filename = intg%process_id // ".var.log"
              end if
              call msg_message ("Name clash for global logfile and process log: ", &
                   arr =[var_str ("| Renaming log file from ") // local%logfile, &
                         var_str ("|   to ") // log_filename // var_str (" .")])
           else
              log_filename = intg%log_filename
           end if
           call intg%process%write_logfile (i_mci, log_filename)
        end if
     end do
 
     if (n_mci > 1 .and. display_summed) then
        call msg_message ("Integrate: sum of all components")
        call intg%process%display_summed_results (pacify)
     end if
 
     call process_instance%final ()
     deallocate (process_instance)
   contains
     subroutine setup_hooks ()
       class(process_instance_hook_t), pointer :: hook
       call dispatch_evt_shower_hook (hook, var_list, process_instance)
       if (associated (hook)) then
          call process_instance%append_after_hook (hook)
       end if
     end subroutine setup_hooks
   end subroutine integration_integrate
 
 @ %def integration_integrate
 @ Do a dummy integration for a process which could not be initialized (e.g.,
 has no matrix element).  The result is zero.
 <<Integrations: integration: TBP>>=
   procedure :: integrate_dummy => integration_integrate_dummy
 <<Integrations: procedures>>=
   subroutine integration_integrate_dummy (intg)
     class(integration_t), intent(inout) :: intg
     call intg%process%integrate_dummy ()
   end subroutine integration_integrate_dummy
 
 @ %def integration_integrate_dummy
 @ Just sample the matrix element under realistic conditions (but no
 cuts); throw away the results.
 <<Integrations: integration: TBP>>=
   procedure :: sampler_test => integration_sampler_test
 <<Integrations: procedures>>=
   subroutine integration_sampler_test (intg)
     class(integration_t), intent(inout) :: intg
     type(process_instance_t), allocatable, target :: process_instance
     integer :: n_mci, i_mci
     type(timer_t) :: timer_mci, timer_tot
     real(default) :: t_mci, t_tot
     allocate (process_instance)
     call process_instance%init (intg%process)
     n_mci = intg%process%get_n_mci ()
     if (n_mci == 1) then
        write (msg_buffer, "(A,A,A)") &
             "Test: probing process '", &
             char (intg%process%get_id ()), "'"
        call msg_message ()
     end if
     call timer_tot%start ()
     do i_mci = 1, n_mci
        if (n_mci > 1) then
           write (msg_buffer, "(A,A,A,I0)") &
                "Test: probing process '", &
                char (intg%process%get_id ()), "' part ", i_mci
           call msg_message ()
        end if
        call timer_mci%start ()
        call process_instance%sampler_test (i_mci, intg%n_calls_test)
        call timer_mci%stop ()
        t_mci = timer_mci
        write (msg_buffer, "(A,ES12.5)")  "Test: " &
             // "time in seconds (wallclock): ", t_mci
        call msg_message ()
     end do
     call timer_tot%stop ()
     t_tot = timer_tot
     if (n_mci > 1) then
        write (msg_buffer, "(A,ES12.5)")  "Test: " &
             // "total time      (wallclock): ", t_tot
        call msg_message ()
     end if
     call process_instance%final ()
   end subroutine integration_sampler_test
 
 @ %def integration_sampler_test
 @ Return the process pointer (needed by simulate):
 <<Integrations: integration: TBP>>=
   procedure :: get_process_ptr => integration_get_process_ptr
 <<Integrations: procedures>>=
   function integration_get_process_ptr (intg) result (ptr)
     class(integration_t), intent(in) :: intg
     type(process_t), pointer :: ptr
     ptr => intg%process
   end function integration_get_process_ptr
 
 @ %def integration_get_process_ptr
 @ Simply integrate, do a dummy integration if necessary.  The [[integration]]
 object exists only internally.
 
 If the [[global]] environment is provided, the process object is appended to
 the global stack.  Otherwise, if [[local_stack]] is set, we append to the
 local process stack.  If this is unset, the [[process]] object is not recorded
 permanently.
 
 The [[init_only]] flag can be used to skip the actual integration part.  We
 will end up with a process object that is completely initialized, including
 phase space configuration.
 
 The [[eff_reset]] flag is to suppress numerical noise in the visualization
 of the integration history.
 <<Integrations: public>>=
   public :: integrate_process
 <<Integrations: procedures>>=
   subroutine integrate_process (process_id, local, global, local_stack, init_only, eff_reset)
     type(string_t), intent(in) :: process_id
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), optional, target :: global
     logical, intent(in), optional :: local_stack, init_only, eff_reset
     type(string_t) :: prclib_name
     type(integration_t) :: intg
     character(32) :: buffer
   <<Integrations: integrate process: variables>>
   <<Integrations: integrate process: init>>
     if (.not. associated (local%prclib)) then
        call msg_fatal ("Integrate: current process library is undefined")
        return
     end if
 
     if (.not. local%prclib%is_active ()) then
        call msg_message ("Integrate: current process library needs compilation")
        prclib_name = local%prclib%get_name ()
        call compile_library (prclib_name, local)
        if (signal_is_pending ())  return
        call msg_message ("Integrate: compilation done")
     end if
 
     call intg%init (process_id, local, global, local_stack, init_only)
     if (signal_is_pending ())  return
 
     if (present (init_only)) then
        if (init_only) return
     end if
 
     if (intg%n_calls_test > 0) then
        write (buffer, "(I0)")  intg%n_calls_test
        call msg_message ("Integrate: test (" // trim (buffer) // " calls) ...")
        call intg%sampler_test ()
        call msg_message ("Integrate: ... test complete.")
        if (signal_is_pending ())  return
     end if
   <<Integrations: integrate process: end init>>
 
     if (intg%phs_only) then
        call msg_message ("Integrate: phase space only, skipping integration")
     else
        if (intg%process_has_me) then
           call intg%integrate (local, eff_reset)
        else
           call intg%integrate_dummy ()
        end if
     end if
   end subroutine integrate_process
 
 @ %def integrate_process
 <<Integrations: integrate process: variables>>=
 @
 <<Integrations: integrate process: init>>=
 @
 <<Integrations: integrate process: end init>>=
 @
 @ The parallelization leads to undefined behavior while writing simultaneously to one file.
 The master worker has to initialize single-handed the corresponding library files and the phase space file.
 The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag.
 <<MPI: Integrations: integrate process: variables>>=
   type(var_list_t), pointer :: var_list
   logical :: mpi_logging, process_init
   integer :: rank, n_size
 <<MPI: Integrations: integrate process: init>>=
   if (debug_on) call msg_debug (D_MPI, "integrate_process")
   var_list => local%get_var_list_ptr ()
   process_init = .false.
   call mpi_get_comm_id (n_size, rank)
   mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) .and. &
        & (n_size > 1)) .or. var_list%get_lval (var_str ("?mpi_logging")))
   if (debug_on) call msg_debug (D_MPI, "n_size", rank)
   if (debug_on) call msg_debug (D_MPI, "rank", rank)
   if (debug_on) call msg_debug (D_MPI, "mpi_logging", mpi_logging)
   if (rank /= 0) then
      if (mpi_logging) then
         call msg_message ("MPI: wait for master to finish process initialization ...")
      end if
      call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
   else
      process_init = .true.
   end if
 
   if (process_init) then
 <<MPI: Integrations: integrate process: end init>>=
   if (rank == 0) then
      if (mpi_logging) then
         call msg_message ("MPI: finish process initialization, load slaves ...")
      end if
      call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
   end if
 end if
 call MPI_barrier (MPI_COMM_WORLD)
 call mpi_set_logging (mpi_logging)
 @ %def integrate_process_mpi
 @
 \subsection{Unit Tests}
 Test module, followed by the stand-alone unit-test procedures.
 <<[[integrations_ut.f90]]>>=
 <<File header>>
 
 module integrations_ut
   use unit_tests
   use integrations_uti
 
 <<Standard module head>>
 
 <<Integrations: public test>>
 
 contains
 
 <<Integrations: test driver>>
 
 end module integrations_ut
 @ %def integrations_ut
 @
 <<[[integrations_uti.f90]]>>=
 <<File header>>
 
 module integrations_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use ifiles
   use lexers
   use parser
   use io_units
   use flavors
   use interactions, only: reset_interaction_counter
   use phs_forests
   use eval_trees
   use models
   use rt_data
   use process_configurations_ut, only: prepare_test_library
   use compilations, only: compile_library
 
   use integrations
 
   use phs_wood_ut, only: write_test_phs_file
 
 <<Standard module head>>
 
 <<Integrations: test declarations>>
 
 contains
 
 <<Integrations: tests>>
 
 end module integrations_uti
 
 @ %def integrations_uti
 @ API: driver for the unit tests below.
 <<Integrations: public test>>=
   public :: integrations_test
 <<Integrations: test driver>>=
   subroutine integrations_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Integrations: execute tests>>
   end subroutine integrations_test
 
 @ %def integrations_test
 @
 <<Integrations: public test>>=
   public :: integrations_history_test
 <<Integrations: test driver>>=
   subroutine integrations_history_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Integrations: execute history tests>>
   end subroutine integrations_history_test
 
 @ %def integrations_history_test
 @
 \subsubsection{Integration of test process}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type).  The phase-space implementation is [[phs_single]]
 (single-particle phase space), the integrator is [[mci_midpoint]].
 
 The cross section for the $2\to 2$ process $ss\to ss$ with its
 constant matrix element is given by
 \begin{equation}
   \sigma = c\times f\times \Phi_2 \times |M|^2.
 \end{equation}
 $c$ is the conversion constant
 \begin{equation}
   c = 0.3894\times 10^{12}\;\mathrm{fb}\,\mathrm{GeV}^2.
 \end{equation}
 $f$ is the flux of the incoming particles with mass
 $m=125\,\mathrm{GeV}$ and energy $\sqrt{s}=1000\,\mathrm{GeV}$
 \begin{equation}
   f = \frac{(2\pi)^4}{2\lambda^{1/2}(s,m^2,m^2)}
     = \frac{(2\pi)^4}{2\sqrt{s}\,\sqrt{s - 4m^2}}
     = 8.048\times 10^{-4}\;\mathrm{GeV}^{-2}
 \end{equation}
 $\Phi_2$ is the volume of the two-particle phase space
 \begin{equation}
   \Phi_2 = \frac{1}{4(2\pi)^5} = 2.5529\times 10^{-5}.
 \end{equation}
 The squared matrix element $|M|^2$ is unity.
 Combining everything, we obtain
 \begin{equation}
   \sigma = 8000\;\mathrm{fb}
 \end{equation}
 This number should appear as the final result.
 
 Note: In this and the following test, we reset the Fortran compiler and flag
 variables immediately before they are printed, so the test is portable.
 <<Integrations: execute tests>>=
   call test (integrations_1, "integrations_1", &
        "intrinsic test process", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_1
 <<Integrations: tests>>=
   subroutine integrations_1 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: integrations_1"
     write (u, "(A)")  "*   Purpose: integrate test process"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
 
     libname = "integration_1"
     procname = "prc_config_a"
 
     call prepare_test_library (global, libname, 1)
     call compile_library (libname, global)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("integrations1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%write (u, vars = [ &
          var_str ("$method"), &
          var_str ("sqrts"), &
          var_str ("$integration_method"), &
          var_str ("$phs_method"), &
          var_str ("$run_id")])
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_1"
 
   end subroutine integrations_1
 
 @ %def integrations_1
 @
 \subsubsection{Integration with cuts}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type) with cuts set.
 <<Integrations: execute tests>>=
   call test (integrations_2, "integrations_2", &
        "intrinsic test process with cut", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_2
 <<Integrations: tests>>=
   subroutine integrations_2 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
 
     type(string_t) :: cut_expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: parse_tree
 
     type(string_t), dimension(0) :: empty_string_array
 
     write (u, "(A)")  "* Test output: integrations_2"
     write (u, "(A)")  "*   Purpose: integrate test process with cut"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
 
     write (u, "(A)")  "* Prepare a cut expression"
     write (u, "(A)")
 
     call syntax_pexpr_init ()
     cut_expr_text = "all Pt > 100 [s]"
     call ifile_append (ifile, cut_expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (parse_tree, stream, .true.)
     global%pn%cuts_lexpr => parse_tree%get_root_ptr ()
 
     write (u, "(A)")  "* Build and initialize a test process"
     write (u, "(A)")
 
     libname = "integration_3"
     procname = "prc_config_a"
 
     call prepare_test_library (global, libname, 1)
     call compile_library (libname, global)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("integrations1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%write (u, vars = empty_string_array)
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_2"
 
   end subroutine integrations_2
 
 @ %def integrations_2
 @
 \subsubsection{Standard phase space}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type) using the default ([[phs_wood]]) phase-space implementation.  We
 use an explicit phase-space configuration file with a single channel
 and integrate by [[mci_midpoint]].
 <<Integrations: execute tests>>=
   call test (integrations_3, "integrations_3", &
        "standard phase space", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_3
 <<Integrations: tests>>=
   subroutine integrations_3 (u)
   <<Use kinds>>
   <<Use strings>>
     use interactions, only: reset_interaction_counter
     use models
     use rt_data
     use process_configurations_ut, only: prepare_test_library
     use compilations, only: compile_library
     use integrations
 
     implicit none
 
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
     integer :: u_phs
 
     write (u, "(A)")  "* Test output: integrations_3"
     write (u, "(A)")  "*   Purpose: integrate test process"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and parameters"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
 
     libname = "integration_3"
     procname = "prc_config_a"
 
     call prepare_test_library (global, libname, 1)
     call compile_library (libname, global)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("integrations1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("default"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?phs_s_mapping"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     write (u, "(A)")  "* Create a scratch phase-space file"
     write (u, "(A)")
 
     u_phs = free_unit ()
     open (u_phs, file = "integrations_3.phs", &
          status = "replace", action = "write")
     call write_test_phs_file (u_phs, var_str ("prc_config_a_i1"))
     close (u_phs)
 
     call global%set_string (var_str ("$phs_file"),&
          var_str ("integrations_3.phs"), is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     write (u, "(A)")  "* Integrate"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%write (u, vars = [ &
          var_str ("$phs_method"), &
          var_str ("$phs_file")])
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_phs_forest_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_3"
 
   end subroutine integrations_3
 
 @ %def integrations_3
 @
 \subsubsection{VAMP integration}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type) using the single-channel ([[phs_single]]) phase-space
 implementation.  The integration method is [[vamp]].
 <<Integrations: execute tests>>=
   call test (integrations_4, "integrations_4", &
        "VAMP integration (one iteration)", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_4
 <<Integrations: tests>>=
   subroutine integrations_4 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: integrations_4"
     write (u, "(A)")  "*   Purpose: integrate test process using VAMP"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and parameters"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
 
     libname = "integrations_4_lib"
     procname = "integrations_4"
 
     call prepare_test_library (global, libname, 1, [procname])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     write (u, "(A)")  "* Integrate"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%pacify (efficiency_reset = .true., error_reset = .true.)
     call global%write (u, vars = [var_str ("$integration_method")], &
             pacify = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_4"
 
   end subroutine integrations_4
 
 @ %def integrations_4
 @
 \subsubsection{Multiple iterations integration}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type) using the single-channel ([[phs_single]]) phase-space
 implementation.  The integration method is [[vamp]].  We launch three
 iterations.
 <<Integrations: execute tests>>=
   call test (integrations_5, "integrations_5", &
        "VAMP integration (three iterations)", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_5
 <<Integrations: tests>>=
   subroutine integrations_5 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
 
     write (u, "(A)")  "* Test output: integrations_5"
     write (u, "(A)")  "*   Purpose: integrate test process using VAMP"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and parameters"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
 
     libname = "integrations_5_lib"
     procname = "integrations_5"
 
     call prepare_test_library (global, libname, 1, [procname])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([3], [1000])
 
     write (u, "(A)")  "* Integrate"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%pacify (efficiency_reset = .true., error_reset = .true.)
     call global%write (u, vars = [var_str ("$integration_method")], &
             pacify = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_5"
 
   end subroutine integrations_5
 
 @ %def integrations_5
 @
 \subsubsection{Multiple passes integration}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type) using the single-channel ([[phs_single]]) phase-space
 implementation.  The integration method is [[vamp]].  We launch three
 passes with three iterations each.
 <<Integrations: execute tests>>=
   call test (integrations_6, "integrations_6", &
        "VAMP integration (three passes)", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_6
 <<Integrations: tests>>=
   subroutine integrations_6 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
     type(string_t), dimension(0) :: no_vars
 
     write (u, "(A)")  "* Test output: integrations_6"
     write (u, "(A)")  "*   Purpose: integrate test process using VAMP"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and parameters"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
 
     libname = "integrations_6_lib"
     procname = "integrations_6"
 
     call prepare_test_library (global, libname, 1, [procname])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], &
          adapt = [.true., .true., .false.], &
          adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])
 
     write (u, "(A)")  "* Integrate"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%pacify (efficiency_reset = .true., error_reset = .true.)
     call global%write (u, vars = no_vars, pacify = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_6"
 
   end subroutine integrations_6
 
 @ %def integrations_6
 @
 \subsubsection{VAMP and default phase space}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type) using the default ([[phs_wood]]) phase-space
 implementation.  The integration method is [[vamp]].  We launch three
 passes with three iterations each.  We enable channel equivalences and
 groves.
 <<Integrations: execute tests>>=
   call test (integrations_7, "integrations_7", &
        "VAMP integration with wood phase space", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_7
 <<Integrations: tests>>=
   subroutine integrations_7 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
     type(string_t), dimension(0) :: no_vars
     integer :: iostat, u_phs
     character(95) :: buffer
     type(string_t) :: phs_file
     logical :: exist
 
     write (u, "(A)")  "* Test output: integrations_7"
     write (u, "(A)")  "*   Purpose: integrate test process using VAMP"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and parameters"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
 
     libname = "integrations_7_lib"
     procname = "integrations_7"
 
     call prepare_test_library (global, libname, 1, [procname])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .true., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?phs_s_mapping"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], &
          adapt = [.true., .true., .false.], &
          adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])
 
     write (u, "(A)")  "* Integrate"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%pacify (efficiency_reset = .true., error_reset = .true.)
     call global%write (u, vars = no_vars, pacify = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_phs_forest_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Generated phase-space file"
     write (u, "(A)")
 
     phs_file = procname // ".r1.i1.phs"
     inquire (file = char (phs_file), exist = exist)
     if (exist) then
        u_phs = free_unit ()
        open (u_phs, file = char (phs_file), action = "read", status = "old")
        iostat = 0
        do while (iostat == 0)
           read (u_phs, "(A)", iostat = iostat)  buffer
           if (iostat == 0)  write (u, "(A)")  trim (buffer)
        end do
        close (u_phs)
     else
        write (u, "(A)")  "[file is missing]"
     end if
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_7"
 
   end subroutine integrations_7
 
 @ %def integrations_7
 @
 \subsubsection{Structure functions}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type) using the default ([[phs_wood]]) phase-space
 implementation.  The integration method is [[vamp]].  There is a structure
 function of type [[unit_test]].
 
 We use a test structure function $f(x)=x$ for both beams.  Together with the
 $1/x_1x_2$ factor from the phase-space flux and a unit matrix element, we
 should get the same result as previously for the process without structure
 functions.  There is a slight correction due to the $m_s$ mass which we set to
 zero here.
 <<Integrations: execute tests>>=
   call test (integrations_8, "integrations_8", &
        "integration with structure function", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_8
 <<Integrations: tests>>=
   subroutine integrations_8 (u)
   <<Use kinds>>
   <<Use strings>>
     use interactions, only: reset_interaction_counter
     use phs_forests
     use models
     use rt_data
     use process_configurations_ut, only: prepare_test_library
     use compilations, only: compile_library
     use integrations
 
     implicit none
 
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
     type(flavor_t) :: flv
     type(string_t) :: name
 
     write (u, "(A)")  "* Test output: integrations_8"
     write (u, "(A)")  "*   Purpose: integrate test process using VAMP &
          &with structure function"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and parameters"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
 
     libname = "integrations_8_lib"
     procname = "integrations_8"
 
     call prepare_test_library (global, libname, 1, [procname])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .true., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?phs_s_mapping"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%model_set_real (var_str ("ms"), 0._default)
 
     call reset_interaction_counter ()
 
     call flv%init (25, global%model)
 
     name = flv%get_name ()
     call global%beam_structure%init_sf ([name, name], [1])
     call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
 
     write (u, "(A)")  "* Integrate"
     write (u, "(A)")
 
     call global%it_list%init ([1], [1000])
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%write (u, vars = [var_str ("ms")])
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_phs_forest_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_8"
 
   end subroutine integrations_8
 
 @ %def integrations_8
 @
 \subsubsection{Integration with sign change}
 Compile and integrate an intrinsic test matrix element ([[prc_test]]
 type).  The phase-space implementation is [[phs_single]]
 (single-particle phase space), the integrator is [[mci_midpoint]].
 The weight that is applied changes the sign in half of phase space.
 The weight is $-3$ and $1$, respectively, so the total result is equal
 to the original, but negative sign.
 
 The efficiency should (approximately) become the average of $1$ and
 $1/3$, that is $2/3$.
 <<Integrations: execute tests>>=
   call test (integrations_9, "integrations_9", &
        "handle sign change", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_9
 <<Integrations: tests>>=
   subroutine integrations_9 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
 
     type(string_t) :: wgt_expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: parse_tree
 
     write (u, "(A)")  "* Test output: integrations_9"
     write (u, "(A)")  "*   Purpose: integrate test process"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
 
     write (u, "(A)")  "* Prepare a weight expression"
     write (u, "(A)")
 
     call syntax_pexpr_init ()
     wgt_expr_text = "eval 2 * sgn (Pz) - 1 [s]"
     call ifile_append (ifile, wgt_expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (parse_tree, stream, .true.)
     global%pn%weight_expr => parse_tree%get_root_ptr ()
 
     write (u, "(A)")  "* Build and evaluate a test process"
     write (u, "(A)")
 
     libname = "integration_9"
     procname = "prc_config_a"
 
     call prepare_test_library (global, libname, 1)
     call compile_library (libname, global)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("integrations1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true.)
 
     call global%write (u, vars = [ &
          var_str ("$method"), &
          var_str ("sqrts"), &
          var_str ("$integration_method"), &
          var_str ("$phs_method"), &
          var_str ("$run_id")])
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_9"
 
   end subroutine integrations_9
 
 @ %def integrations_9
 @
 \subsubsection{Integration history for VAMP integration with default
   phase space}
 This test is only run when event analysis can be done.
 <<Integrations: execute history tests>>=
   call test (integrations_history_1, "integrations_history_1", &
        "Test integration history files", &
        u, results)
 <<Integrations: test declarations>>=
   public :: integrations_history_1
 <<Integrations: tests>>=
   subroutine integrations_history_1 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname
     type(rt_data_t), target :: global
     type(string_t), dimension(0) :: no_vars
     integer :: iostat, u_his
     character(91) :: buffer
     type(string_t) :: his_file, ps_file, pdf_file
     logical :: exist, exist_ps, exist_pdf
 
     write (u, "(A)")  "* Test output: integrations_history_1"
     write (u, "(A)")  "*   Purpose: test integration history files"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and parameters"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
 
     libname = "integrations_history_1_lib"
     procname = "integrations_history_1"
 
     call global%set_log (var_str ("?vis_history"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?phs_s_mapping"),&
          .false., is_known = .true.)
 
     call prepare_test_library (global, libname, 1, [procname])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .true., is_known = .true.)
     call global%set_real (var_str ("error_threshold"),&
          5E-6_default, is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known=.true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([2, 2, 2], [1000, 1000, 1000], &
          adapt = [.true., .true., .false.], &
          adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])
 
     write (u, "(A)")  "* Integrate"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call integrate_process (procname, global, local_stack=.true., &
          eff_reset = .true.)
 
     call global%pacify (efficiency_reset = .true., error_reset = .true.)
     call global%write (u, vars = no_vars, pacify = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generated history files"
     write (u, "(A)")
 
     his_file = procname // ".r1.history.tex"
     ps_file  = procname // ".r1.history.ps"
     pdf_file = procname // ".r1.history.pdf"
     inquire (file = char (his_file), exist = exist)
     if (exist) then
        u_his = free_unit ()
        open (u_his, file = char (his_file), action = "read", status = "old")
        iostat = 0
        do while (iostat == 0)
           read (u_his, "(A)", iostat = iostat)  buffer
           if (iostat == 0)  write (u, "(A)")  trim (buffer)
        end do
        close (u_his)
     else
        write (u, "(A)")  "[History LaTeX file is missing]"
     end if
     inquire (file = char (ps_file), exist = exist_ps)
     if (exist_ps) then
        write (u, "(A)")  "[History Postscript file exists and is nonempty]"
     else
        write (u, "(A)")  "[History Postscript file is missing/non-regular]"
     end if
     inquire (file = char (pdf_file), exist = exist_pdf)
     if (exist_pdf) then
        write (u, "(A)")  "[History PDF file exists and is nonempty]"
     else
        write (u, "(A)")  "[History PDF file is missing/non-regular]"
     end if
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_phs_forest_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: integrations_history_1"
 
   end subroutine integrations_history_1
 
 @ %def integrations_history_1
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Event Streams}
 This module manages I/O from/to multiple concurrent event streams.
 Usually, there is at most one input stream, but several output
 streams.  For the latter, we set up an array which can hold [[eio_t]]
 (event I/O) objects of different dynamic types simultaneously.  One of
 them may be marked as an input channel.
 <<[[event_streams.f90]]>>=
 <<File header>>
 
 module event_streams
 
 <<Use strings>>
   use io_units
   use diagnostics
   use events
   use event_handles, only: event_handle_t
   use eio_data
   use eio_base
   use rt_data
 
   use dispatch_transforms, only: dispatch_eio
 
 <<Standard module head>>
 
 <<Event streams: public>>
 
 <<Event streams: types>>
 
 contains
 
 <<Event streams: procedures>>
 
 end module event_streams
 @ %def event_streams
 @
 \subsection{Event Stream Array}
 Each entry is an [[eio_t]] object.  Since the type is dynamic, we need
 a wrapper:
 <<Event streams: types>>=
   type :: event_stream_entry_t
      class(eio_t), allocatable :: eio
   end type event_stream_entry_t
 
 @ %def event_stream_entry_t
 @ An array of event-stream entry objects.  If one of the entries is an
 input channel, [[i_in]] is the corresponding index.
 <<Event streams: public>>=
   public :: event_stream_array_t
 <<Event streams: types>>=
   type :: event_stream_array_t
      type(event_stream_entry_t), dimension(:), allocatable :: entry
      integer :: i_in = 0
    contains
    <<Event streams: event stream array: TBP>>
   end type event_stream_array_t
 
 @ %def event_stream_array_t
 @ Output.
 <<Event streams: event stream array: TBP>>=
   procedure :: write => event_stream_array_write
 <<Event streams: procedures>>=
   subroutine event_stream_array_write (object, unit)
     class(event_stream_array_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Event stream array:"
     if (allocated (object%entry)) then
        select case (size (object%entry))
        case (0)
           write (u, "(3x,A)")  "[empty]"
        case default
           do i = 1, size (object%entry)
              if (i == object%i_in)  write (u, "(1x,A)")  "Input stream:"
              call object%entry(i)%eio%write (u)
           end do
        end select
     else
        write (u, "(3x,A)")  "[undefined]"
     end if
   end subroutine event_stream_array_write
 
 @ %def event_stream_array_write
 @ Check if there is content.
 <<Event streams: event stream array: TBP>>=
   procedure :: is_valid => event_stream_array_is_valid
 <<Event streams: procedures>>=
   function event_stream_array_is_valid (es_array) result (flag)
     class(event_stream_array_t), intent(in) :: es_array
     logical :: flag
     
     flag = allocated (es_array%entry)
     
   end function event_stream_array_is_valid
   
 @ %def event_stream_array_is_valid
 @ Finalize all streams.
 <<Event streams: event stream array: TBP>>=
   procedure :: final => event_stream_array_final
 <<Event streams: procedures>>=
   subroutine event_stream_array_final (es_array)
     class(event_stream_array_t), intent(inout) :: es_array
     integer :: i
     if (allocated (es_array%entry)) then
        do i = 1, size (es_array%entry)
           call es_array%entry(i)%eio%final ()
        end do
     end if
   end subroutine event_stream_array_final
 
 @ %def event_stream_array_final
 @ Initialization.  We use a generic [[sample]] name, open event I/O
 objects for all provided stream types (using the [[dispatch_eio]]
 routine), and initialize for the given list of process pointers.  If
 there is an [[input]] argument, this channel is initialized as an input
 channel and appended to the array.
 
 The [[input_data]] or, if not present, [[data]] may be modified.  This
 happens if we open a stream for reading and get new information there.
 <<Event streams: event stream array: TBP>>=
   procedure :: init => event_stream_array_init
 <<Event streams: procedures>>=
   subroutine event_stream_array_init &
        (es_array, sample, stream_fmt, global, &
        data, input, input_sample, input_data, allow_switch, &
        checkpoint, callback, &
        error)
     class(event_stream_array_t), intent(out) :: es_array
     type(string_t), intent(in) :: sample
     type(string_t), dimension(:), intent(in) :: stream_fmt
     type(rt_data_t), intent(in) :: global
     type(event_sample_data_t), intent(inout), optional :: data
     type(string_t), intent(in), optional :: input
     type(string_t), intent(in), optional :: input_sample
     type(event_sample_data_t), intent(inout), optional :: input_data
     logical, intent(in), optional :: allow_switch
     integer, intent(in), optional :: checkpoint
     integer, intent(in), optional :: callback
     logical, intent(out), optional :: error
     type(string_t) :: sample_in
     integer :: n, i, n_output, i_input, i_checkpoint, i_callback
     logical :: success, switch
     if (present (input_sample)) then
        sample_in = input_sample
     else
        sample_in = sample
     end if
     if (present (allow_switch)) then
        switch = allow_switch
     else
        switch = .true.
     end if
     if (present (error)) then
        error = .false.
     end if
     n = size (stream_fmt)
     n_output = n
     if (present (input)) then
        n = n + 1
        i_input = n
     else
        i_input = 0
     end if
     if (present (checkpoint)) then
        n = n + 1
        i_checkpoint = n
     else
        i_checkpoint = 0
     end if
     if (present (callback)) then
        n = n + 1
        i_callback = n
     else
        i_callback = 0
     end if
     allocate (es_array%entry (n))
     if (i_checkpoint > 0) then
        call dispatch_eio &
             (es_array%entry(i_checkpoint)%eio, var_str ("checkpoint"), &
             global%var_list, global%fallback_model, &
             global%event_callback)
        call es_array%entry(i_checkpoint)%eio%init_out (sample, data)
     end if
     if (i_callback > 0) then
        call dispatch_eio &
             (es_array%entry(i_callback)%eio, var_str ("callback"), &
             global%var_list, global%fallback_model, &
             global%event_callback)
        call es_array%entry(i_callback)%eio%init_out (sample, data)
     end if
     if (i_input > 0) then
        call dispatch_eio (es_array%entry(i_input)%eio, input, &
             global%var_list, global%fallback_model, &
             global%event_callback)
        if (present (input_data)) then
           call es_array%entry(i_input)%eio%init_in &
                (sample_in, input_data, success)
        else
           call es_array%entry(i_input)%eio%init_in &
                (sample_in, data, success)
        end if
        if (success) then
           es_array%i_in = i_input
        else if (present (input_sample)) then
           if (present (error)) then
              error = .true.
           else
              call msg_fatal ("Events: &
                   &parameter mismatch in input, aborting")
           end if
        else
           call msg_message ("Events: &
                &parameter mismatch, discarding old event set")
           call es_array%entry(i_input)%eio%final ()
           if (switch) then
              call msg_message ("Events: generating new events")
              call es_array%entry(i_input)%eio%init_out (sample, data)
           end if
        end if
     end if
     do i = 1, n_output
        call dispatch_eio (es_array%entry(i)%eio, stream_fmt(i), &
             global%var_list, global%fallback_model, &
             global%event_callback)
        call es_array%entry(i)%eio%init_out (sample, data)
     end do
   end subroutine event_stream_array_init
 
 @ %def event_stream_array_init
 @ Switch the (only) input channel to an output channel, so further
 events are appended to the respective stream.
 <<Event streams: event stream array: TBP>>=
   procedure :: switch_inout => event_stream_array_switch_inout
 <<Event streams: procedures>>=
   subroutine event_stream_array_switch_inout (es_array)
     class(event_stream_array_t), intent(inout) :: es_array
     integer :: n
     if (es_array%has_input ()) then
        n = es_array%i_in
        call es_array%entry(n)%eio%switch_inout ()
        es_array%i_in = 0
     else
        call msg_bug ("Reading events: switch_inout: no input stream selected")
     end if
   end subroutine event_stream_array_switch_inout
 
 @ %def event_stream_array_switch_inout
 @ Output an event (with given process number) to all output streams.
 If there is no output stream, do nothing.
 <<Event streams: event stream array: TBP>>=
   procedure :: output => event_stream_array_output
 <<Event streams: procedures>>=
   subroutine event_stream_array_output &
        (es_array, event, i_prc, event_index, passed, pacify, event_handle)
     class(event_stream_array_t), intent(inout) :: es_array
     type(event_t), intent(in), target :: event
     integer, intent(in) :: i_prc, event_index
     logical, intent(in), optional :: passed, pacify
     class(event_handle_t), intent(inout), optional :: event_handle
     logical :: increased
     integer :: i
     do i = 1, size (es_array%entry)
        if (i /= es_array%i_in) then
           associate (eio => es_array%entry(i)%eio)
             if (eio%split) then
                if (eio%split_n_evt > 0 .and. event_index > 1) then
                   if (mod (event_index, eio%split_n_evt) == 1) then
                      call eio%split_out ()
                   end if
                else if (eio%split_n_kbytes > 0) then
                   call eio%update_split_count (increased)
                   if (increased)  call eio%split_out ()
                end if
             end if
             call eio%output (event, i_prc, reading = es_array%i_in /= 0, &
                  passed = passed, &
                  pacify = pacify, &
                  event_handle = event_handle)
           end associate
        end if
     end do
   end subroutine event_stream_array_output
 
 @ %def event_stream_array_output
 @ Input the [[i_prc]] index which selects the process for the current
 event.  This is separated from reading the event, because it
 determines which event record to read.  [[iostat]] may indicate an
 error or an EOF condition, as usual.
 <<Event streams: event stream array: TBP>>=
   procedure :: input_i_prc => event_stream_array_input_i_prc
 <<Event streams: procedures>>=
   subroutine event_stream_array_input_i_prc (es_array, i_prc, iostat)
     class(event_stream_array_t), intent(inout) :: es_array
     integer, intent(out) :: i_prc
     integer, intent(out) :: iostat
     integer :: n
     if (es_array%has_input ()) then
        n = es_array%i_in
        call es_array%entry(n)%eio%input_i_prc (i_prc, iostat)
     else
        call msg_fatal ("Reading events: no input stream selected")
     end if
   end subroutine event_stream_array_input_i_prc
 
 @ %def event_stream_array_input_i_prc
 @ Input an event from the selected input stream.  [[iostat]] may indicate an
 error or an EOF condition, as usual.
 <<Event streams: event stream array: TBP>>=
   procedure :: input_event => event_stream_array_input_event
 <<Event streams: procedures>>=
   subroutine event_stream_array_input_event &
        (es_array, event, iostat, event_handle)
     class(event_stream_array_t), intent(inout) :: es_array
     type(event_t), intent(inout), target :: event
     integer, intent(out) :: iostat
     class(event_handle_t), intent(inout), optional :: event_handle
     integer :: n
     if (es_array%has_input ()) then
        n = es_array%i_in
        call es_array%entry(n)%eio%input_event (event, iostat, event_handle)
     else
        call msg_fatal ("Reading events: no input stream selected")
     end if
   end subroutine event_stream_array_input_event
 
 @ %def event_stream_array_input_event
 @ Skip an entry of eio\_t. Used to synchronize the event read-in for
 NLO events.
 <<Event streams: event stream array: TBP>>=
   procedure :: skip_eio_entry => event_stream_array_skip_eio_entry
 <<Event streams: procedures>>=
   subroutine event_stream_array_skip_eio_entry (es_array, iostat)
     class(event_stream_array_t), intent(inout) :: es_array
     integer, intent(out) :: iostat
     integer :: n
     if (es_array%has_input ()) then
        n = es_array%i_in
        call es_array%entry(n)%eio%skip (iostat)
     else
        call msg_fatal ("Reading events: no input stream selected")
     end if
   end subroutine event_stream_array_skip_eio_entry
 
 @ %def event_stream_array_skip_eio_entry
 @ Return true if there is an input channel among the event streams.
 <<Event streams: event stream array: TBP>>=
   procedure :: has_input => event_stream_array_has_input
 <<Event streams: procedures>>=
   function event_stream_array_has_input (es_array) result (flag)
     class(event_stream_array_t), intent(in) :: es_array
     logical :: flag
     flag = es_array%i_in /= 0
   end function event_stream_array_has_input
 
 @ %def event_stream_array_has_input
 @
 \subsection{Unit Tests}
 Test module, followed by the stand-alone unit-test procedures.
 <<[[event_streams_ut.f90]]>>=
 <<File header>>
 
 module event_streams_ut
   use unit_tests
   use event_streams_uti
 
 <<Standard module head>>
 
 <<Event streams: public test>>
 
 contains
 
 <<Event streams: test driver>>
 
 end module event_streams_ut
 @
 <<[[event_streams_uti.f90]]>>=
 <<File header>>
 
 module event_streams_uti
 
 <<Use kinds>>
 <<Use strings>>
   use model_data
   use eio_data
   use process, only: process_t
   use instances, only: process_instance_t
   use models
   use rt_data
   use events
 
   use event_streams
 
 <<Standard module head>>
 
 <<Event streams: test declarations>>
 
 contains
 
 <<Event streams: tests>>
 
 end module event_streams_uti
 
 @ %def event_streams_uti
 @ API: driver for the unit tests below.
 <<Event streams: public test>>=
   public :: event_streams_test
 <<Event streams: test driver>>=
   subroutine event_streams_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Event streams: execute tests>>
   end subroutine event_streams_test
 
 @ %def event_streams_test
 @
 \subsubsection{Empty event stream}
 This should set up an empty event output stream array, including
 initialization, output, and finalization (which are all no-ops).
 <<Event streams: execute tests>>=
   call test (event_streams_1, "event_streams_1", &
        "empty event stream array", &
        u, results)
 <<Event streams: test declarations>>=
   public :: event_streams_1
 <<Event streams: tests>>=
   subroutine event_streams_1 (u)
     integer, intent(in) :: u
     type(event_stream_array_t) :: es_array
     type(rt_data_t) :: global
     type(event_t) :: event
     type(string_t) :: sample
     type(string_t), dimension(0) :: empty_string_array
 
     write (u, "(A)")  "* Test output: event_streams_1"
     write (u, "(A)")  "*   Purpose: handle empty event stream array"
     write (u, "(A)")
 
     sample = "event_streams_1"
 
     call es_array%init (sample, empty_string_array, global)
     call es_array%output (event, 42, 1)
     call es_array%write (u)
     call es_array%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: event_streams_1"
 
   end subroutine event_streams_1
 
 @ %def event_streams_1
 @
 \subsubsection{Nontrivial event stream}
 Here we generate a trivial event and choose [[raw]] output as an entry in
 the stream array.
 <<Event streams: execute tests>>=
   call test (event_streams_2, "event_streams_2", &
        "nontrivial event stream array", &
        u, results)
 <<Event streams: test declarations>>=
   public :: event_streams_2
 <<Event streams: tests>>=
   subroutine event_streams_2 (u)
     use processes_ut, only: prepare_test_process
     integer, intent(in) :: u
     type(event_stream_array_t) :: es_array
     type(rt_data_t) :: global
     type(model_data_t), target :: model
     type(event_t), allocatable, target :: event
     type(process_t), allocatable, target :: process
     type(process_instance_t), allocatable, target :: process_instance
     type(string_t) :: sample
     type(string_t), dimension(0) :: empty_string_array
     integer :: i_prc, iostat
 
     write (u, "(A)")  "* Test output: event_streams_2"
     write (u, "(A)")  "*   Purpose: handle empty event stream array"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call model%init_test ()
 
     write (u, "(A)")  "* Generate test process event"
     write (u, "(A)")
 
     allocate (process)
     allocate (process_instance)
     call prepare_test_process (process, process_instance, model, &
          run_id = var_str ("run_test"))
     call process_instance%setup_event_data ()
 
     allocate (event)
     call event%basic_init ()
     call event%connect (process_instance, process%get_model_ptr ())
     call event%generate (1, [0.4_default, 0.4_default])
     call event%set_index (42)
     call event%evaluate_expressions ()
     call event%write (u)
 
     write (u, "(A)")
     write (u, "(A)") "* Allocate raw eio stream and write event to file"
     write (u, "(A)")
 
     sample = "event_streams_2"
 
     call es_array%init (sample, [var_str ("raw")], global)
     call es_array%output (event, 1, 1)
     call es_array%write (u)
     call es_array%final ()
 
     write (u, "(A)")
     write (u, "(A)") "* Reallocate raw eio stream for reading"
     write (u, "(A)")
 
     sample = "foo"
     call es_array%init (sample, empty_string_array, global, &
          input = var_str ("raw"), input_sample = var_str ("event_streams_2"))
     call es_array%write (u)
 
     write (u, "(A)")
     write (u, "(A)") "* Reread event"
     write (u, "(A)")
 
     call es_array%input_i_prc (i_prc, iostat)
 
     write (u, "(1x,A,I0)")  "i_prc = ", i_prc
     write (u, "(A)")
     call es_array%input_event (event, iostat)
     call es_array%final ()
 
     call event%write (u)
 
     call global%final ()
 
     call model%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: event_streams_2"
 
   end subroutine event_streams_2
 
 @ %def event_streams_2
 @
 \subsubsection{Switch in/out}
 Here we generate an event file and test switching from writing to
 reading when the file is exhausted.
 <<Event streams: execute tests>>=
   call test (event_streams_3, "event_streams_3", &
        "switch input/output", &
        u, results)
 <<Event streams: test declarations>>=
   public :: event_streams_3
 <<Event streams: tests>>=
   subroutine event_streams_3 (u)
     use processes_ut, only: prepare_test_process
     integer, intent(in) :: u
     type(event_stream_array_t) :: es_array
     type(rt_data_t) :: global
     type(model_data_t), target :: model
     type(event_t), allocatable, target :: event
     type(process_t), allocatable, target :: process
     type(process_instance_t), allocatable, target :: process_instance
     type(string_t) :: sample
     type(string_t), dimension(0) :: empty_string_array
     integer :: i_prc, iostat
 
     write (u, "(A)")  "* Test output: event_streams_3"
     write (u, "(A)")  "*   Purpose: handle in/out switching"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call model%init_test ()
 
     write (u, "(A)")  "* Generate test process event"
     write (u, "(A)")
 
     allocate (process)
     allocate (process_instance)
     call prepare_test_process (process, process_instance, model, &
          run_id = var_str ("run_test"))
     call process_instance%setup_event_data ()
 
     allocate (event)
     call event%basic_init ()
     call event%connect (process_instance, process%get_model_ptr ())
     call event%generate (1, [0.4_default, 0.4_default])
     call event%increment_index ()
     call event%evaluate_expressions ()
 
     write (u, "(A)") "* Allocate raw eio stream and write event to file"
     write (u, "(A)")
 
     sample = "event_streams_3"
 
     call es_array%init (sample, [var_str ("raw")], global)
     call es_array%output (event, 1, 1)
     call es_array%write (u)
     call es_array%final ()
 
     write (u, "(A)")
     write (u, "(A)") "* Reallocate raw eio stream for reading"
     write (u, "(A)")
 
     call es_array%init (sample, empty_string_array, global, &
          input = var_str ("raw"))
     call es_array%write (u)
 
     write (u, "(A)")
     write (u, "(A)") "* Reread event"
     write (u, "(A)")
 
     call es_array%input_i_prc (i_prc, iostat)
     call es_array%input_event (event, iostat)
 
     write (u, "(A)") "* Attempt to read another event (fail), then generate"
     write (u, "(A)")
 
     call es_array%input_i_prc (i_prc, iostat)
     if (iostat < 0) then
        call es_array%switch_inout ()
        call event%generate (1, [0.3_default, 0.3_default])
        call event%increment_index ()
        call event%evaluate_expressions ()
        call es_array%output (event, 1, 2)
     end if
     call es_array%write (u)
     call es_array%final ()
 
     write (u, "(A)")
     call event%write (u)
 
     write (u, "(A)")
     write (u, "(A)") "* Reallocate raw eio stream for reading"
     write (u, "(A)")
 
     call es_array%init (sample, empty_string_array, global, &
          input = var_str ("raw"))
     call es_array%write (u)
 
     write (u, "(A)")
     write (u, "(A)") "* Reread two events and display 2nd event"
     write (u, "(A)")
 
     call es_array%input_i_prc (i_prc, iostat)
     call es_array%input_event (event, iostat)
     call es_array%input_i_prc (i_prc, iostat)
 
     call es_array%input_event (event, iostat)
     call es_array%final ()
 
     call event%write (u)
 
     call global%final ()
 
     call model%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: event_streams_3"
 
   end subroutine event_streams_3
 
 @ %def event_streams_3
 @
 \subsubsection{Checksum}
 Here we generate an event file and repeat twice, once with identical
 parameters and once with modified parameters.
 <<Event streams: execute tests>>=
   call test (event_streams_4, "event_streams_4", &
        "check MD5 sum", &
        u, results)
 <<Event streams: test declarations>>=
   public :: event_streams_4
 <<Event streams: tests>>=
   subroutine event_streams_4 (u)
     integer, intent(in) :: u
     type(event_stream_array_t) :: es_array
     type(rt_data_t) :: global
     type(process_t), allocatable, target :: process
     type(string_t) :: sample
     type(string_t), dimension(0) :: empty_string_array
     type(event_sample_data_t) :: data
 
     write (u, "(A)")  "* Test output: event_streams_4"
     write (u, "(A)")  "*   Purpose: handle in/out switching"
     write (u, "(A)")
 
     write (u, "(A)")  "* Generate test process event"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%set_log (var_str ("?check_event_file"), &
          .true., is_known = .true.)
 
     allocate (process)
 
     write (u, "(A)") "* Allocate raw eio stream for writing"
     write (u, "(A)")
 
     sample = "event_streams_4"
     data%md5sum_cfg = "1234567890abcdef1234567890abcdef"
 
     call es_array%init (sample, [var_str ("raw")], global, data)
     call es_array%write (u)
     call es_array%final ()
 
     write (u, "(A)")
     write (u, "(A)") "* Reallocate raw eio stream for reading"
     write (u, "(A)")
 
     call es_array%init (sample, empty_string_array, global, &
          data, input = var_str ("raw"))
     call es_array%write (u)
     call es_array%final ()
 
     write (u, "(A)")
     write (u, "(A)") "* Reallocate modified raw eio stream for reading (fail)"
     write (u, "(A)")
 
     data%md5sum_cfg = "1234567890______1234567890______"
     call es_array%init (sample, empty_string_array, global, &
          data, input = var_str ("raw"))
     call es_array%write (u)
     call es_array%final ()
 
     write (u, "(A)")
     write (u, "(A)") "* Repeat ignoring checksum"
     write (u, "(A)")
 
     call global%set_log (var_str ("?check_event_file"), &
          .false., is_known = .true.)
     call es_array%init (sample, empty_string_array, global, &
          data, input = var_str ("raw"))
     call es_array%write (u)
     call es_array%final ()
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: event_streams_4"
 
   end subroutine event_streams_4
 
 @ %def event_streams_4
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Restricted Subprocesses}
 This module provides an automatic means to construct restricted subprocesses
 of a current process object.  A restricted subprocess has the same initial and
 final state as the current process, but a restricted set of Feynman graphs.
 
 The actual application extracts the set of resonance histories that apply to
 the process and uses this to construct subprocesses that are restricted to one
 of those histories, respectively.  The resonance histories are derived from
 the phase-space setup.  This implies that the method is tied to the OMega
 matrix element generator and to the wood phase space method.
 
 The processes are collected in a new process library that is generated
 on-the-fly.
 
 The [[resonant_subprocess_t]] object is intended as a component of the event
 record, which manages all operations regarding resonance handling.
 
 The run-time calculations are delegated to an event transform
 ([[evt_resonance_t]]), as a part of the event transform chain.  The transform
 selects one (or none) of the resonance histories, given the momentum
 configuration, computes matrix elements and inserts resonances into the
 particle set.
 <<[[restricted_subprocesses.f90]]>>=
 <<File header>>
 
 module restricted_subprocesses
 
 <<Use kinds>>
 <<Use strings>>
   use diagnostics, only: msg_message, msg_fatal, msg_bug
   use diagnostics, only: signal_is_pending
   use io_units, only: given_output_unit
   use format_defs, only: FMT_14, FMT_19
   use string_utils, only: str
   use lorentz, only: vector4_t
   use particle_specifiers, only: prt_spec_t
   use particles, only: particle_set_t
   use resonances, only: resonance_history_t, resonance_history_set_t
   use variables, only: var_list_t
   use models, only: model_t
   use process_libraries, only: process_component_def_t
   use process_libraries, only: process_library_t
   use process_libraries, only: STAT_ACTIVE
   use prclib_stacks, only: prclib_entry_t
   use event_transforms, only: evt_t
   use resonance_insertion, only: evt_resonance_t
   use rt_data, only: rt_data_t
   use compilations, only: compile_library
   use process_configurations, only: process_configuration_t
   use process, only: process_t, process_ptr_t
   use instances, only: process_instance_t, process_instance_ptr_t
   use integrations, only: integrate_process
 
 <<Use mpi f08>>
 
 <<Standard module head>>
 
 <<Restricted subprocesses: public>>
 
 <<Restricted subprocesses: types>>
 
 <<Restricted subprocesses: interfaces>>
 
 contains
 
 <<Restricted subprocesses: procedures>>
 
 end module restricted_subprocesses
 @ %def restricted_subprocesses
 @
 \subsection{Process configuration}
 We extend the [[process_configuration_t]] by another method for initialization
 that takes into account a resonance history.
 <<Restricted subprocesses: public>>=
   public :: restricted_process_configuration_t
 <<Restricted subprocesses: types>>=
   type, extends (process_configuration_t) :: restricted_process_configuration_t
      private
    contains
    <<Restricted subprocesses: restricted process configuration: TBP>>
   end type restricted_process_configuration_t
 
 @ %def restricted_process_configuration_t
 @
 Resonance history as an argument.  We use it to override the [[restrictions]]
 setting in a local variable list.  Since we can construct the restricted
 process only by using OMega, we enforce it as the ME method.  Other settings
 are taken from the variable list.  The model will most likely be set, but we
 insert a safeguard just in case.
 
 Also, the resonant subprocess should not itself spawn resonant
 subprocesses, so we unset [[?resonance_history]].
 
 We have to create a local copy of the model here, via pointer
 allocation.  The reason is that the model as stored (via pointer) in
 the base type will be finalized and deallocated.
 
 The current implementation will generate a LO process, the optional
 [[nlo_process]] is unset.  (It is not obvious
 whether the construction makes sense beyond LO.)
 <<Restricted subprocesses: restricted process configuration: TBP>>=
   procedure :: init_resonant_process
 <<Restricted subprocesses: procedures>>=
   subroutine init_resonant_process &
        (prc_config, prc_name, prt_in, prt_out, res_history, model, var_list)
     class(restricted_process_configuration_t), intent(out) :: prc_config
     type(string_t), intent(in) :: prc_name
     type(prt_spec_t), dimension(:), intent(in) :: prt_in
     type(prt_spec_t), dimension(:), intent(in) :: prt_out
     type(resonance_history_t), intent(in) :: res_history
     type(model_t), intent(in), target :: model
     type(var_list_t), intent(in), target :: var_list
     type(model_t), pointer :: local_model
     type(var_list_t) :: local_var_list
     allocate (local_model)
     call local_model%init_instance (model)
     call local_var_list%link (var_list)
     call local_var_list%append_string (var_str ("$model_name"), &
          sval = local_model%get_name (), &
          intrinsic=.true.)
     call local_var_list%append_string (var_str ("$method"), &
          sval = var_str ("omega"), &
          intrinsic=.true.)
     call local_var_list%append_string (var_str ("$restrictions"), &
          sval = res_history%as_omega_string (size (prt_in)), &
          intrinsic = .true.)
     call local_var_list%append_log (var_str ("?resonance_history"), &
          lval = .false., &
          intrinsic = .true.)
     call prc_config%init (prc_name, size (prt_in), 1, &
          local_model, local_var_list)
     call prc_config%setup_component (1, &
          prt_in, prt_out, &
          local_model, local_var_list)
   end subroutine init_resonant_process
 
 @ %def init_resonant_process
 @
 \subsection{Resonant-subprocess set manager}
 This data type enables generation of a library of resonant subprocesses for a
 given master process, and it allows for convenient access.  The matrix
 elements from the subprocesses can be used as channel weights to activate a
 selector, which then returns a preferred channel via some random number
 generator.
 <<Restricted subprocesses: public>>=
   public :: resonant_subprocess_set_t
 <<Restricted subprocesses: types>>=
   type :: resonant_subprocess_set_t
      private
      integer, dimension(:), allocatable :: n_history
      type(resonance_history_set_t), dimension(:), allocatable :: res_history_set
      logical :: lib_active = .false.
      type(string_t) :: libname
      type(string_t), dimension(:), allocatable :: proc_id
      type(process_ptr_t), dimension(:), allocatable :: subprocess
      type(process_instance_ptr_t), dimension(:), allocatable :: instance
      logical :: filled = .false.
      type(evt_resonance_t), pointer :: evt => null ()
    contains
    <<Restricted subprocesses: resonant subprocess set: TBP>>
   end type resonant_subprocess_set_t
 
 @ %def resonant_subprocess_set_t
 @ Output
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: write => resonant_subprocess_set_write
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_write (prc_set, unit, testflag)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     logical :: truncate
     integer :: u, i
     u = given_output_unit (unit)
     truncate = .false.;  if (present (testflag))  truncate = testflag
     write (u, "(1x,A)")  "Resonant subprocess set:"
     if (allocated (prc_set%n_history)) then
        if (any (prc_set%n_history > 0)) then
           do i = 1, size (prc_set%n_history)
              if (prc_set%n_history(i) > 0) then
                 write (u, "(1x,A,I0)")  "Component #", i
                 call prc_set%res_history_set(i)%write (u, indent=1)
              end if
           end do
           if (prc_set%lib_active) then
              write (u, "(3x,A,A,A)")  "Process library = '", &
                   char (prc_set%libname), "'"
           else
              write (u, "(3x,A)")  "Process library: [inactive]"
           end if
           if (associated (prc_set%evt)) then
              if (truncate) then
                 write (u, "(3x,A,1x," // FMT_14 // ")") &
                      "Process sqme =", prc_set%get_master_sqme ()
              else
                 write (u, "(3x,A,1x," // FMT_19 // ")") &
                      "Process sqme =", prc_set%get_master_sqme ()
              end if
           end if
           if (associated (prc_set%evt)) then
              write (u, "(3x,A)")  "Event transform: associated"
              write (u, "(2x)", advance="no")
              call prc_set%evt%write_selector (u, testflag)
           else
              write (u, "(3x,A)")  "Event transform: not associated"
           end if
        else
           write (u, "(2x,A)")  "[empty]"
        end if
     else
        write (u, "(3x,A)")  "[not allocated]"
     end if
   end subroutine resonant_subprocess_set_write
 
 @ %def resonant_subprocess_set_write
 @
 \subsection{Resonance history set}
 Initialize subprocess set with an array of pre-created resonance
 history sets.
 
 Safeguard: if there are no resonances in the input, initialize the local set
 as empty, but complete.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: init => resonant_subprocess_set_init
   procedure :: fill_resonances => resonant_subprocess_set_fill_resonances
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_init (prc_set, n_component)
     class(resonant_subprocess_set_t), intent(out) :: prc_set
     integer, intent(in) :: n_component
     allocate (prc_set%res_history_set (n_component))
     allocate (prc_set%n_history (n_component), source = 0)
   end subroutine resonant_subprocess_set_init
 
   subroutine resonant_subprocess_set_fill_resonances (prc_set, &
        res_history_set, i_component)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     type(resonance_history_set_t), intent(in) :: res_history_set
     integer, intent(in) :: i_component
     prc_set%n_history(i_component) = res_history_set%get_n_history ()
     if (prc_set%n_history(i_component) > 0) then
        prc_set%res_history_set(i_component) = res_history_set
     else
        call prc_set%res_history_set(i_component)%init (initial_size = 0)
        call prc_set%res_history_set(i_component)%freeze ()
     end if
   end subroutine resonant_subprocess_set_fill_resonances
 
 @ %def resonant_subprocess_set_init
 @ %def resonant_subprocess_set_fill_resonances
 @ Return the resonance history set.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: get_resonance_history_set &
        => resonant_subprocess_set_get_resonance_history_set
 <<Restricted subprocesses: procedures>>=
   function resonant_subprocess_set_get_resonance_history_set (prc_set) &
        result (res_history_set)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     type(resonance_history_set_t), dimension(:), allocatable :: res_history_set
     res_history_set = prc_set%res_history_set
   end function resonant_subprocess_set_get_resonance_history_set
 
 @ %def resonant_subprocess_set_get_resonance_history_set
 @
 \subsection{Library for the resonance history set}
 The recommended library name: append [[_R]] to the process name.
 <<Restricted subprocesses: public>>=
   public :: get_libname_res
 <<Restricted subprocesses: procedures>>=
   elemental function get_libname_res (proc_id) result (libname)
     type(string_t), intent(in) :: proc_id
     type(string_t) :: libname
     libname = proc_id // "_R"
   end function get_libname_res
 
 @ %def get_libname_res
 @ Here we scan the global process library whether any
 processes require resonant subprocesses to be constructed.  If yes,
 create process objects with phase space and construct the process
 libraries as usual.  Then append the library names to the array.
 
 The temporary integration objects should carry the [[phs_only]]
 flag.  We set this in the local environment.
 
 Once a process object with resonance histories (derived from phase
 space) has been created, we extract the resonance histories and use
 them, together with the process definition, to create the new library.
 
 Finally, compile the library.
 <<Restricted subprocesses: public>>=
   public :: spawn_resonant_subprocess_libraries
 <<Restricted subprocesses: procedures>>=
   subroutine spawn_resonant_subprocess_libraries &
        (libname, local, global, libname_res)
     type(string_t), intent(in) :: libname
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), target :: global
     type(string_t), dimension(:), allocatable, intent(inout) :: libname_res
     type(process_library_t), pointer :: lib
     type(string_t), dimension(:), allocatable :: process_id_res
     type(process_t), pointer :: process
     type(resonance_history_set_t) :: res_history_set
     type(process_component_def_t), pointer :: process_component_def
     logical :: phs_only_saved, exist
     integer :: i_proc, i_component
     lib => global%prclib_stack%get_library_ptr (libname)
     call lib%get_process_id_req_resonant (process_id_res)
     if (size (process_id_res) > 0) then
        call msg_message ("Creating resonant-subprocess libraries &
             &for library '" // char (libname) // "'")
        libname_res = get_libname_res (process_id_res)
        phs_only_saved = local%var_list%get_lval (var_str ("?phs_only"))
        call local%var_list%set_log &
             (var_str ("?phs_only"), .true., is_known=.true.)
        do i_proc = 1, size (process_id_res)
           associate (proc_id => process_id_res (i_proc))
             call msg_message ("Process '" // char (proc_id) // "': &
                  &constructing phase space for resonance structure")
             call integrate_process (proc_id, local, global)
             process => global%process_stack%get_process_ptr (proc_id)
             call create_library (libname_res(i_proc), global, exist)
             if (.not. exist) then
                do i_component = 1, process%get_n_components ()
                   call process%extract_resonance_history_set &
                        (res_history_set, i_component = i_component)
                   process_component_def &
                        => process%get_component_def_ptr (i_component)
                   call add_to_library (libname_res(i_proc), &
                        res_history_set, &
                        process_component_def%get_prt_spec_in (), &
                        process_component_def%get_prt_spec_out (), &
                        global)
                end do
                call msg_message ("Process library '" &
                     // char (libname_res(i_proc)) &
                     // "': created")
             end if
             call global%update_prclib (lib)
           end associate
        end do
        call local%var_list%set_log &
             (var_str ("?phs_only"), phs_only_saved, is_known=.true.)
     end if
   end subroutine spawn_resonant_subprocess_libraries
 
 @ %def spawn_resonant_subprocess_libraries
 @ This is another version of the library constructor, bound to a
 restricted-subprocess set object.  Create the appropriate
 process library, add processes, and close the library.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: create_library => resonant_subprocess_set_create_library
   procedure :: add_to_library => resonant_subprocess_set_add_to_library
   procedure :: freeze_library => resonant_subprocess_set_freeze_library
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_create_library (prc_set, &
        libname, global, exist)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     type(string_t), intent(in) :: libname
     type(rt_data_t), intent(inout), target :: global
     logical, intent(out) :: exist
     prc_set%libname = libname
     call create_library (prc_set%libname, global, exist)
   end subroutine resonant_subprocess_set_create_library
 
   subroutine resonant_subprocess_set_add_to_library (prc_set, &
        i_component, prt_in, prt_out, global)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     integer, intent(in) :: i_component
     type(prt_spec_t), dimension(:), intent(in) :: prt_in
     type(prt_spec_t), dimension(:), intent(in) :: prt_out
     type(rt_data_t), intent(inout), target :: global
     call add_to_library (prc_set%libname, &
          prc_set%res_history_set(i_component), &
          prt_in, prt_out, global)
   end subroutine resonant_subprocess_set_add_to_library
 
   subroutine resonant_subprocess_set_freeze_library (prc_set, global)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     type(rt_data_t), intent(inout), target :: global
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     lib => global%prclib_stack%get_library_ptr (prc_set%libname)
     call lib%get_process_id_list (prc_set%proc_id)
     prc_set%lib_active = .true.
   end subroutine resonant_subprocess_set_freeze_library
 
 @ %def resonant_subprocess_set_create_library
 @ %def resonant_subprocess_set_add_to_library
 @ %def resonant_subprocess_set_freeze_library
 @ The common parts of the procedures above: (i) create a new process
 library or recover it, (ii) for each history, create a
 process configuration and record it.
 <<Restricted subprocesses: procedures>>=
   subroutine create_library (libname, global, exist)
     type(string_t), intent(in) :: libname
     type(rt_data_t), intent(inout), target :: global
     logical, intent(out) :: exist
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     type(resonance_history_t) :: res_history
     type(string_t), dimension(:), allocatable :: proc_id
     type(restricted_process_configuration_t) :: prc_config
     integer :: i
     lib => global%prclib_stack%get_library_ptr (libname)
     exist = associated (lib)
     if (.not. exist) then
        call msg_message ("Creating library for resonant subprocesses '" &
             // char (libname) // "'")
        allocate (lib_entry)
        call lib_entry%init (libname)
        lib => lib_entry%process_library_t
        call global%add_prclib (lib_entry)
     else
        call msg_message ("Using library for resonant subprocesses '" &
             // char (libname) // "'")
        call global%update_prclib (lib)
     end if
   end subroutine create_library
 
   subroutine add_to_library (libname, res_history_set, prt_in, prt_out, global)
     type(string_t), intent(in) :: libname
     type(resonance_history_set_t), intent(in) :: res_history_set
     type(prt_spec_t), dimension(:), intent(in) :: prt_in
     type(prt_spec_t), dimension(:), intent(in) :: prt_out
     type(rt_data_t), intent(inout), target :: global
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     type(resonance_history_t) :: res_history
     type(string_t), dimension(:), allocatable :: proc_id
     type(restricted_process_configuration_t) :: prc_config
     integer :: n0, i
     lib => global%prclib_stack%get_library_ptr (libname)
     if (associated (lib)) then
        n0 = lib%get_n_processes ()
        allocate (proc_id (res_history_set%get_n_history ()))
        do i = 1, size (proc_id)
           proc_id(i) = libname // str (n0 + i)
           res_history = res_history_set%get_history(i)
           call prc_config%init_resonant_process (proc_id(i), &
                prt_in, prt_out, &
                res_history, &
                global%model, global%var_list)
           call msg_message ("Resonant subprocess #" &
                // char (str(n0+i)) // ": " &
                // char (res_history%as_omega_string (size (prt_in))))
           call prc_config%record (global)
           if (signal_is_pending ())  return
        end do
     else
        call msg_bug ("Adding subprocesses: library '" &
             // char (libname) // "' not found")
     end if
   end subroutine add_to_library
 
 @ %def create_library
 @ %def add_to_library
 @ Compile the generated library, required settings taken from the
 [[global]] data set.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: compile_library => resonant_subprocess_set_compile_library
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_compile_library (prc_set, global)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     type(rt_data_t), intent(inout), target :: global
     type(process_library_t), pointer :: lib
     lib => global%prclib_stack%get_library_ptr (prc_set%libname)
     if (lib%get_status () < STAT_ACTIVE) then
        call compile_library (prc_set%libname, global)
     end if
   end subroutine resonant_subprocess_set_compile_library
 
 @ %def resonant_subprocess_set_compile_library
 @ Check if the library has been created / the process has been evaluated.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: is_active => resonant_subprocess_set_is_active
 <<Restricted subprocesses: procedures>>=
   function resonant_subprocess_set_is_active (prc_set) result (flag)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     logical :: flag
     flag = prc_set%lib_active
   end function resonant_subprocess_set_is_active
 
 @ %def resonant_subprocess_set_is_active
 @ Return number of generated process objects, library, and process IDs.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: get_n_process => resonant_subprocess_set_get_n_process
   procedure :: get_libname => resonant_subprocess_set_get_libname
   procedure :: get_proc_id => resonant_subprocess_set_get_proc_id
 <<Restricted subprocesses: procedures>>=
   function resonant_subprocess_set_get_n_process (prc_set) result (n)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     integer :: n
     if (prc_set%lib_active) then
        n = size (prc_set%proc_id)
     else
        n = 0
     end if
   end function resonant_subprocess_set_get_n_process
 
   function resonant_subprocess_set_get_libname (prc_set) result (libname)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     type(string_t) :: libname
     if (prc_set%lib_active) then
        libname = prc_set%libname
     else
        libname = ""
     end if
   end function resonant_subprocess_set_get_libname
 
   function resonant_subprocess_set_get_proc_id (prc_set, i) result (proc_id)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     integer, intent(in) :: i
     type(string_t) :: proc_id
     if (allocated (prc_set%proc_id)) then
        proc_id = prc_set%proc_id(i)
     else
        proc_id = ""
     end if
   end function resonant_subprocess_set_get_proc_id
 
 @ %def resonant_subprocess_set_get_n_process
 @ %def resonant_subprocess_set_get_libname
 @ %def resonant_subprocess_set_get_proc_id
 @
 \subsection{Process objects and instances}
 Prepare process objects for all entries in the resonant-subprocesses
 library.  The process objects are appended to the global process
 stack.  A local environment can be used where we place temporary
 variable settings that affect process-object generation.  We
 initialize the processes, such that we can evaluate matrix elements,
 but we do not need to integrate them.
 
 The internal procedure [[prepare_process]] is an abridged version of
 the procedure with this name in the [[simulations]] module.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: prepare_process_objects &
        => resonant_subprocess_set_prepare_process_objects
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_prepare_process_objects &
        (prc_set, local, global)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), optional, target :: global
     type(rt_data_t), pointer :: current
     type(process_library_t), pointer :: lib
     type(string_t) :: proc_id, libname_cur, libname_res
     integer :: i, n
     if (.not. prc_set%is_active ())  return
     if (present (global)) then
        current => global
     else
        current => local
     end if
     libname_cur = current%prclib%get_name ()
     libname_res = prc_set%get_libname ()
     lib => current%prclib_stack%get_library_ptr (libname_res)
     if (associated (lib))  call current%update_prclib (lib)
     call local%set_string (var_str ("$phs_method"), &
             var_str ("none"), is_known = .true.)
     call local%set_string (var_str ("$integration_method"), &
             var_str ("none"), is_known = .true.)
     n = prc_set%get_n_process ()
     allocate (prc_set%subprocess (n))
     do i = 1, n
        proc_id = prc_set%get_proc_id (i)
        call prepare_process (prc_set%subprocess(i)%p, proc_id)
        if (signal_is_pending ())  return
     end do
     lib => current%prclib_stack%get_library_ptr (libname_cur)
     if (associated (lib))  call current%update_prclib (lib)
   contains
     subroutine prepare_process (process, process_id)
       type(process_t), pointer, intent(out) :: process
       type(string_t), intent(in) :: process_id
       call msg_message ("Simulate: initializing resonant subprocess '" &
                // char (process_id) // "'")
       if (present (global)) then
          call integrate_process (process_id, local, global, &
               init_only = .true.)
       else
          call integrate_process (process_id, local, local_stack = .true., &
               init_only = .true.)
       end if
       process => current%process_stack%get_process_ptr (process_id)
       if (.not. associated (process)) then
          call msg_fatal ("Simulate: resonant subprocess '" &
                // char (process_id) // "' could not be initialized: aborting")
       end if
     end subroutine prepare_process
   end subroutine resonant_subprocess_set_prepare_process_objects
 
 @ %def resonant_subprocess_set_prepare_process_objects
 @ Workspace for the resonant subprocesses.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: prepare_process_instances &
        => resonant_subprocess_set_prepare_process_instances
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_prepare_process_instances (prc_set, global)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     type(rt_data_t), intent(in), target :: global
     integer :: i, n
     if (.not. prc_set%is_active ())  return
     n = size (prc_set%subprocess)
     allocate (prc_set%instance (n))
     do i = 1, n
        allocate (prc_set%instance(i)%p)
        call prc_set%instance(i)%p%init (prc_set%subprocess(i)%p)
        call prc_set%instance(i)%p%setup_event_data (global%model)
     end do
   end subroutine resonant_subprocess_set_prepare_process_instances
 
 @ %def resonant_subprocess_set_prepare_process_instances
 @
 \subsection{Event transform connection}
 The idea is that the resonance-insertion event transform has been
 allocated somewhere (namely, in the standard event-transform chain),
 but we maintain a link such that we can inject matrix-element results
 event by event.  The event transform holds a selector, to choose one
 of the resonance histories (or none), and it manages resonance
 insertion for the particle set.
 
 The data that the event transform requires can be provided here.  The
 resonance history set has already been assigned with the [[dispatch]]
 initializer.  Here, we supply the set of subprocess instances that we
 have generated (see above).  The master-process instance is set
 when we [[connect]] the transform by the standard method.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: connect_transform => &
        resonant_subprocess_set_connect_transform
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_connect_transform (prc_set, evt)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     class(evt_t), intent(in), target :: evt
     select type (evt)
     type is (evt_resonance_t)
        prc_set%evt => evt
        call prc_set%evt%set_subprocess_instances (prc_set%instance)
     class default
        call msg_bug ("Resonant subprocess set: event transform has wrong type")
     end select
   end subroutine resonant_subprocess_set_connect_transform
 
 @ %def resonant_subprocess_set_connect_transform
 @ Set the on-shell limit value in the connected transform.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: set_on_shell_limit => resonant_subprocess_set_on_shell_limit
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_on_shell_limit (prc_set, on_shell_limit)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     real(default), intent(in) :: on_shell_limit
     call prc_set%evt%set_on_shell_limit (on_shell_limit)
   end subroutine resonant_subprocess_set_on_shell_limit
 
 @ %def resonant_subprocess_set_on_shell_limit
 @ Set the Gaussian turnoff parameter in the connected transform.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: set_on_shell_turnoff => resonant_subprocess_set_on_shell_turnoff
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_on_shell_turnoff &
        (prc_set, on_shell_turnoff)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     real(default), intent(in) :: on_shell_turnoff
     call prc_set%evt%set_on_shell_turnoff (on_shell_turnoff)
   end subroutine resonant_subprocess_set_on_shell_turnoff
 
 @ %def resonant_subprocess_set_on_shell_turnoff
 @ Reweight (suppress) the background contribution probability, for the
 kinematics where a resonance history is active.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: set_background_factor &
        => resonant_subprocess_set_background_factor
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_background_factor &
        (prc_set, background_factor)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     real(default), intent(in) :: background_factor
     call prc_set%evt%set_background_factor (background_factor)
   end subroutine resonant_subprocess_set_background_factor
 
 @ %def resonant_subprocess_set_background_factor
 @
 \subsection{Wrappers for runtime calculations}
 All runtime calculations are delegated to the event transform.  The
 following procedures are essentially redundant wrappers.  We retain
 them for a unit test below.
 
 Debugging aid:
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: dump_instances => resonant_subprocess_set_dump_instances
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_dump_instances (prc_set, unit, testflag)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: i, n, u
     u = given_output_unit (unit)
     write (u, "(A)")  "*** Process instances of resonant subprocesses"
     write (u, *)
     n = size (prc_set%subprocess)
     do i = 1, n
        associate (instance => prc_set%instance(i)%p)
          call instance%write (u, testflag)
          write (u, *)
          write (u, *)
        end associate
     end do
   end subroutine resonant_subprocess_set_dump_instances
 
 @ %def resonant_subprocess_set_dump_instances
 @ Inject the current kinematics configuration, reading from the
 previous event transform or from the process instance.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: fill_momenta => resonant_subprocess_set_fill_momenta
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_fill_momenta (prc_set)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     integer :: i, n
     call prc_set%evt%fill_momenta ()
   end subroutine resonant_subprocess_set_fill_momenta
 
 @ %def resonant_subprocess_set_fill_momenta
 @ Determine the indices of the resonance histories that can be
 considered on-shell for the current kinematics.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: determine_on_shell_histories &
        => resonant_subprocess_set_determine_on_shell_histories
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_determine_on_shell_histories &
        (prc_set, i_component, index_array)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     integer, intent(in) :: i_component
     integer, dimension(:), allocatable, intent(out) :: index_array
     call prc_set%evt%determine_on_shell_histories (index_array)
   end subroutine resonant_subprocess_set_determine_on_shell_histories
 
 @ %def resonant_subprocess_set_determine_on_shell_histories
 @ Evaluate selected subprocesses.  (In actual operation, the ones that
 have been tagged as on-shell.)
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: evaluate_subprocess &
        => resonant_subprocess_set_evaluate_subprocess
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_evaluate_subprocess (prc_set, index_array)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     integer, dimension(:), intent(in) :: index_array
     call prc_set%evt%evaluate_subprocess (index_array)
   end subroutine resonant_subprocess_set_evaluate_subprocess
 
 @ %def resonant_subprocess_set_evaluate_subprocess
 @ Extract the matrix elements of the master process / the resonant
 subprocesses.  After the previous routine has been executed, they
 should be available and stored in the corresponding process instances.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: get_master_sqme &
        => resonant_subprocess_set_get_master_sqme
   procedure :: get_subprocess_sqme &
        => resonant_subprocess_set_get_subprocess_sqme
 <<Restricted subprocesses: procedures>>=
   function resonant_subprocess_set_get_master_sqme (prc_set) result (sqme)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     real(default) :: sqme
     sqme = prc_set%evt%get_master_sqme ()
   end function resonant_subprocess_set_get_master_sqme
 
   subroutine resonant_subprocess_set_get_subprocess_sqme (prc_set, sqme)
     class(resonant_subprocess_set_t), intent(in) :: prc_set
     real(default), dimension(:), intent(inout) :: sqme
     integer :: i
     call prc_set%evt%get_subprocess_sqme (sqme)
   end subroutine resonant_subprocess_set_get_subprocess_sqme
 
 @ %def resonant_subprocess_set_get_master_sqme
 @ %def resonant_subprocess_set_get_subprocess_sqme
 @ We use the calculations of resonant matrix elements to determine
 probabilities for all resonance configurations.
 <<Restricted subprocesses: resonant subprocess set: TBP>>=
   procedure :: compute_probabilities &
        => resonant_subprocess_set_compute_probabilities
 <<Restricted subprocesses: procedures>>=
   subroutine resonant_subprocess_set_compute_probabilities (prc_set, prob_array)
     class(resonant_subprocess_set_t), intent(inout) :: prc_set
     real(default), dimension(:), allocatable, intent(out) :: prob_array
     integer, dimension(:), allocatable :: index_array
     real(default) :: sqme, sqme_sum, sqme_bg
     real(default), dimension(:), allocatable :: sqme_res
     integer :: n
     n = size (prc_set%subprocess)
     allocate (prob_array (0:n), source = 0._default)
     call prc_set%evt%compute_probabilities ()
     call prc_set%evt%get_selector_weights (prob_array)
   end subroutine resonant_subprocess_set_compute_probabilities
 
 @ %def resonant_subprocess_set_compute_probabilities
 @
 \subsection{Unit tests}
 Test module, followed by the stand-alone unit-test procedures.
 <<[[restricted_subprocesses_ut.f90]]>>=
 <<File header>>
 
 module restricted_subprocesses_ut
   use unit_tests
   use restricted_subprocesses_uti
 
 <<Standard module head>>
 
 <<Restricted subprocesses: public test>>
 
 contains
 
 <<Restricted subprocesses: test driver>>
 
 end module restricted_subprocesses_ut
 @ %def restricted_subprocesses_ut
 @
 <<[[restricted_subprocesses_uti.f90]]>>=
 <<File header>>
 
 module restricted_subprocesses_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units, only: free_unit
   use format_defs, only: FMT_10, FMT_12
   use lorentz, only: vector4_t, vector3_moving, vector4_moving
   use particle_specifiers, only: new_prt_spec
   use process_libraries, only: process_library_t
   use resonances, only: resonance_info_t
   use resonances, only: resonance_history_t
   use resonances, only: resonance_history_set_t
   use state_matrices, only: FM_IGNORE_HELICITY
   use particles, only: particle_set_t
   use model_data, only: model_data_t
   use models, only: syntax_model_file_init, syntax_model_file_final
   use models, only: model_t
   use rng_base_ut, only: rng_test_factory_t
   use mci_base, only: mci_t
   use mci_none, only: mci_none_t
   use phs_base, only: phs_config_t
   use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final
   use phs_wood, only: phs_wood_config_t
   use process_libraries, only: process_def_entry_t
   use process_libraries, only: process_component_def_t
   use prclib_stacks, only: prclib_entry_t
   use prc_core_def, only: prc_core_def_t
   use prc_omega, only: omega_def_t
   use process, only: process_t
   use instances, only: process_instance_t
   use process_stacks, only: process_entry_t
   use event_transforms, only: evt_trivial_t
   use resonance_insertion, only: evt_resonance_t
   use integrations, only: integrate_process
   use rt_data, only: rt_data_t
 
   use restricted_subprocesses
 
 <<Standard module head>>
 
 <<Restricted subprocesses: test declarations>>
 
 <<Restricted subprocesses: test auxiliary types>>
 
 <<Restricted subprocesses: public test auxiliary>>
 
 contains
 
 <<Restricted subprocesses: tests>>
 
 <<Restricted subprocesses: test auxiliary>>
 
 end module restricted_subprocesses_uti
 
 @ %def restricted_subprocesses_uti
 @ API: driver for the unit tests below.
 <<Restricted subprocesses: public test>>=
   public :: restricted_subprocesses_test
 <<Restricted subprocesses: test driver>>=
   subroutine restricted_subprocesses_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Restricted subprocesses: execute tests>>
   end subroutine restricted_subprocesses_test
 
 @ %def restricted_subprocesses_test
 @
 \subsubsection{subprocess configuration}
 Initialize a [[restricted_subprocess_configuration_t]] object which represents
 a given process with a defined resonance history.
 <<Restricted subprocesses: execute tests>>=
   call test (restricted_subprocesses_1, "restricted_subprocesses_1", &
        "single subprocess", &
        u, results)
 <<Restricted subprocesses: test declarations>>=
   public :: restricted_subprocesses_1
 <<Restricted subprocesses: tests>>=
   subroutine restricted_subprocesses_1 (u)
     integer, intent(in) :: u
     type(rt_data_t) :: global
     type(resonance_info_t) :: res_info
     type(resonance_history_t) :: res_history
     type(string_t) :: prc_name
     type(string_t), dimension(2) :: prt_in
     type(string_t), dimension(3) :: prt_out
     type(restricted_process_configuration_t) :: prc_config
 
     write (u, "(A)")  "* Test output: restricted_subprocesses_1"
     write (u, "(A)")  "*   Purpose: create subprocess list from resonances"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%select_model (var_str ("SM"))
 
     write (u, "(A)")  "* Create resonance history"
     write (u, "(A)")
 
     call res_info%init (3, -24, global%model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create process configuration"
     write (u, "(A)")
 
     prc_name = "restricted_subprocesses_1_p"
     prt_in(1) = "e-"
     prt_in(2) = "e+"
     prt_out(1) = "d"
     prt_out(2) = "u"
     prt_out(3) = "W+"
 
     call prc_config%init_resonant_process (prc_name, &
          new_prt_spec (prt_in), new_prt_spec (prt_out), &
          res_history, global%model, global%var_list)
 
     call prc_config%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: restricted_subprocesses_1"
 
   end subroutine restricted_subprocesses_1
 
 @ %def restricted_subprocesses_1
 @
 \subsubsection{Subprocess library configuration}
 Create a process library that represents restricted subprocesses for a given
 set of resonance histories
 <<Restricted subprocesses: execute tests>>=
   call test (restricted_subprocesses_2, "restricted_subprocesses_2", &
        "subprocess library", &
        u, results)
 <<Restricted subprocesses: test declarations>>=
   public :: restricted_subprocesses_2
 <<Restricted subprocesses: tests>>=
   subroutine restricted_subprocesses_2 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     type(resonance_info_t) :: res_info
     type(resonance_history_t), dimension(2) :: res_history
     type(resonance_history_set_t) :: res_history_set
     type(string_t) :: libname
     type(string_t), dimension(2) :: prt_in
     type(string_t), dimension(3) :: prt_out
     type(resonant_subprocess_set_t) :: prc_set
     type(process_library_t), pointer :: lib
     logical :: exist
 
     write (u, "(A)")  "* Test output: restricted_subprocesses_2"
     write (u, "(A)")  "*   Purpose: create subprocess library from resonances"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%select_model (var_str ("SM"))
 
     write (u, "(A)")  "* Create resonance histories"
     write (u, "(A)")
 
     call res_info%init (3, -24, global%model, 5)
     call res_history(1)%add_resonance (res_info)
     call res_history(1)%write (u)
 
     call res_info%init (7, 23, global%model, 5)
     call res_history(2)%add_resonance (res_info)
     call res_history(2)%write (u)
 
     call res_history_set%init ()
     call res_history_set%enter (res_history(1))
     call res_history_set%enter (res_history(2))
     call res_history_set%freeze ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Empty restricted subprocess set"
     write (u, "(A)")
 
     write (u, "(A,1x,L1)")  "active =", prc_set%is_active ()
     write (u, "(A)")
 
     call prc_set%write (u, testflag=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Fill restricted subprocess set"
     write (u, "(A)")
 
     libname = "restricted_subprocesses_2_p_R"
     prt_in(1) = "e-"
     prt_in(2) = "e+"
     prt_out(1) = "d"
     prt_out(2) = "u"
     prt_out(3) = "W+"
 
     call prc_set%init (1)
     call prc_set%fill_resonances (res_history_set, 1)
     call prc_set%create_library (libname, global, exist)
     if (.not. exist) then
        call prc_set%add_to_library (1, &
             new_prt_spec (prt_in), new_prt_spec (prt_out), &
             global)
     end if
     call prc_set%freeze_library (global)
 
     write (u, "(A,1x,L1)")  "active =", prc_set%is_active ()
     write (u, "(A)")
 
     call prc_set%write (u, testflag=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Queries"
     write (u, "(A)")
 
     write (u, "(A,1x,I0)")  "n_process =", prc_set%get_n_process ()
     write (u, "(A)")
     write (u, "(A,A,A)")  "libname = '", char (prc_set%get_libname ()), "'"
     write (u, "(A)")
     write (u, "(A,A,A)")  "proc_id(1) = '", char (prc_set%get_proc_id (1)), "'"
     write (u, "(A,A,A)")  "proc_id(2) = '", char (prc_set%get_proc_id (2)), "'"
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Process library"
     write (u, "(A)")
 
     call prc_set%compile_library (global)
 
     lib => global%prclib_stack%get_library_ptr (libname)
     if (associated (lib))  call lib%write (u, libpath=.false.)
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: restricted_subprocesses_2"
 
   end subroutine restricted_subprocesses_2
 
 @ %def restricted_subprocesses_2
 @
 \subsubsection{Auxiliary: Test processes}
 Auxiliary subroutine that constructs the process library for the above test.
 This parallels a similar subroutine in [[processes_uti]], but this time we
 want an \oMega\ process.
 <<Restricted subprocesses: public test auxiliary>>=
   public :: prepare_resonance_test_library
 <<Restricted subprocesses: test auxiliary>>=
   subroutine prepare_resonance_test_library &
        (lib, libname, procname, model, global, u)
     type(process_library_t), target, intent(out) :: lib
     type(string_t), intent(in) :: libname
     type(string_t), intent(in) :: procname
     class(model_data_t), intent(in), pointer :: model
     type(rt_data_t), intent(in), target :: global
     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 (omega_def_t :: def)
     select type (def)
     type is (omega_def_t)
        call def%init (model%get_name (), prt_in, prt_out, &
             ovm=.false., ufo=.false.)
     end select
     allocate (entry)
     call entry%init (procname, &
          model_name = model%get_name (), &
          n_in = 2, n_components = 1, &
          requires_resonances = .true.)
     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 entry%write (u)
 
     call lib%append (entry)
 
     call lib%configure (global%os_data)
     call lib%write_makefile (global%os_data, force = .true., verbose = .false.)
     call lib%clean (global%os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (global%os_data)
 
   end subroutine prepare_resonance_test_library
 
 @ %def prepare_resonance_test_library
 @
 \subsubsection{Kinematics and resonance selection}
 Prepare an actual process with resonant subprocesses.  Insert
 kinematics and apply the resonance selector in an associated event
 transform.
 <<Restricted subprocesses: execute tests>>=
   call test (restricted_subprocesses_3, "restricted_subprocesses_3", &
        "resonance kinematics and probability", &
        u, results)
 <<Restricted subprocesses: test declarations>>=
   public :: restricted_subprocesses_3
 <<Restricted subprocesses: tests>>=
   subroutine restricted_subprocesses_3 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     class(model_t), pointer :: model
     class(model_data_t), pointer :: model_data
     type(string_t) :: libname, libname_res
     type(string_t) :: procname
     type(process_component_def_t), pointer :: process_component_def
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     logical :: exist
     type(process_t), pointer :: process
     type(process_instance_t), target :: process_instance
     type(resonance_history_set_t), dimension(1) :: res_history_set
     type(resonant_subprocess_set_t) :: prc_set
     type(particle_set_t) :: pset
     real(default) :: sqrts, mw, pp
     real(default), dimension(3) :: p3
     type(vector4_t), dimension(:), allocatable :: p
     real(default), dimension(:), allocatable :: m
     integer, dimension(:), allocatable :: pdg
     real(default), dimension(:), allocatable :: sqme
     logical, dimension(:), allocatable :: mask
     real(default) :: on_shell_limit
     integer, dimension(:), allocatable :: i_array
     real(default), dimension(:), allocatable :: prob_array
     type(evt_resonance_t), target :: evt_resonance
     integer :: i, u_dump
 
     write (u, "(A)")  "* Test output: restricted_subprocesses_3"
     write (u, "(A)")  "*   Purpose: handle process and resonance kinematics"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%set_log (var_str ("?resonance_history"), &
          .true., is_known = .true.)
 
     call global%select_model (var_str ("SM"))
     allocate (model)
     call model%init_instance (global%model)
     model_data => model
 
     libname = "restricted_subprocesses_3_lib"
     libname_res = "restricted_subprocesses_3_lib_res"
     procname = "restricted_subprocesses_3_p"
 
     write (u, "(A)")  "* Initialize process library and process"
     write (u, "(A)")
 
     allocate (lib_entry)
     call lib_entry%init (libname)
     lib => lib_entry%process_library_t
     call global%add_prclib (lib_entry)
 
     call prepare_resonance_test_library &
          (lib, libname, procname, model_data, global, u)
 
     call integrate_process (procname, global, &
          local_stack = .true., init_only = .true.)
 
     process => global%process_stack%get_process_ptr (procname)
 
     call process_instance%init (process)
     call process_instance%setup_event_data ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract resonance history set"
     write (u, "(A)")
 
     call process%extract_resonance_history_set &
          (res_history_set(1), include_trivial=.true., i_component=1)
     call res_history_set(1)%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build resonant-subprocess library"
     write (u, "(A)")
 
     call prc_set%init (1)
     call prc_set%fill_resonances (res_history_set(1), 1)
 
     process_component_def => process%get_component_def_ptr (1)
     call prc_set%create_library (libname_res, global, exist)
     if (.not. exist) then
        call prc_set%add_to_library (1, &
             process_component_def%get_prt_spec_in (), &
             process_component_def%get_prt_spec_out (), &
             global)
     end if
     call prc_set%freeze_library (global)
     call prc_set%compile_library (global)
     call prc_set%write (u, testflag=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build particle set"
     write (u, "(A)")
 
     sqrts = global%get_rval (var_str ("sqrts"))
     mw = 80._default   ! deliberately slightly different from true mw
     pp = sqrt (sqrts**2 - 4 * mw**2) / 2
 
     allocate (pdg (5), p (5), m (5))
     pdg(1) = -11
     p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
     m(1) = 0
     pdg(2) = 11
     p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
     m(2) = 0
     pdg(3) = 1
     p3(1) = pp/2
     p3(2) = mw/2
     p3(3) = 0
     p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(3) = 0
     p3(2) = -mw/2
     pdg(4) = -2
     p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(4) = 0
     pdg(5) = 24
     p(5) = vector4_moving (sqrts/2,-pp, 1)
     m(5) = mw
 
     call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
     call pset%set_momentum (p, m**2)
     call pset%write (u, testflag=.true.)
 
      write (u, "(A)")
      write (u, "(A)")  "* Fill process instance"
 
     ! workflow from event_recalculate
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1)
     call process_instance%recover &
          (1, 1, update_sqme=.true., recover_phs=.false.)
     call process_instance%evaluate_event_data (weight = 1._default)
 
     write (u, "(A)")
     write (u, "(A)")  "* Prepare resonant subprocesses"
 
     call prc_set%prepare_process_objects (global)
     call prc_set%prepare_process_instances (global)
 
     call evt_resonance%set_resonance_data (res_history_set)
     call evt_resonance%select_component (1)
     call prc_set%connect_transform (evt_resonance)
     call evt_resonance%connect (process_instance, model)
 
     call prc_set%fill_momenta ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Show squared matrix element of master process,"
     write (u, "(A)")  "  should coincide with 2nd subprocess sqme"
     write (u, "(A)")
 
     write (u, "(1x,I0,1x," // FMT_12 // ")")  0, prc_set%get_master_sqme ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute squared matrix elements &
          &of selected resonant subprocesses [1,2]"
     write (u, "(A)")
 
     call prc_set%evaluate_subprocess ([1,2])
 
     allocate (sqme (3), source = 0._default)
     call prc_set%get_subprocess_sqme (sqme)
     do i = 1, size (sqme)
        write (u, "(1x,I0,1x," // FMT_12 // ")")  i, sqme(i)
     end do
     deallocate (sqme)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute squared matrix elements &
          &of all resonant subprocesses"
     write (u, "(A)")
 
     call prc_set%evaluate_subprocess ([1,2,3])
 
     allocate (sqme (3), source = 0._default)
     call prc_set%get_subprocess_sqme (sqme)
     do i = 1, size (sqme)
        write (u, "(1x,I0,1x," // FMT_12 // ")")  i, sqme(i)
     end do
     deallocate (sqme)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write process instances to file &
          &restricted_subprocesses_3_lib_res.dat"
 
     u_dump = free_unit ()
     open (unit = u_dump, file = "restricted_subprocesses_3_lib_res.dat", &
          action = "write", status = "replace")
     call prc_set%dump_instances (u_dump)
     close (u_dump)
 
     write (u, "(A)")
     write (u, "(A)")  "* Determine on-shell resonant subprocesses"
     write (u, "(A)")
 
     on_shell_limit = 0
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit =", on_shell_limit
     call prc_set%set_on_shell_limit (on_shell_limit)
     call prc_set%determine_on_shell_histories (1, i_array)
     write (u, "(1x,A,9(1x,I0))")  "resonant =", i_array
 
     on_shell_limit = 0.1_default
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit =", on_shell_limit
     call prc_set%set_on_shell_limit (on_shell_limit)
     call prc_set%determine_on_shell_histories (1, i_array)
     write (u, "(1x,A,9(1x,I0))")  "resonant =", i_array
 
     on_shell_limit = 10._default
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit =", on_shell_limit
     call prc_set%set_on_shell_limit (on_shell_limit)
     call prc_set%determine_on_shell_histories (1, i_array)
     write (u, "(1x,A,9(1x,I0))")  "resonant =", i_array
 
     on_shell_limit = 10000._default
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit =", on_shell_limit
     call prc_set%set_on_shell_limit (on_shell_limit)
     call prc_set%determine_on_shell_histories (1, i_array)
     write (u, "(1x,A,9(1x,I0))")  "resonant =", i_array
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute probabilities for applicable resonances"
     write (u, "(A)")  "  and initialize the process selector"
     write (u, "(A)")  "  (The first number is the probability for background)"
     write (u, "(A)")
 
     on_shell_limit = 0
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit =", on_shell_limit
     call prc_set%set_on_shell_limit (on_shell_limit)
     call prc_set%determine_on_shell_histories (1, i_array)
     call prc_set%compute_probabilities (prob_array)
     write (u, "(1x,A,9(1x,"// FMT_12 // "))")  "resonant =", prob_array
     call prc_set%write (u, testflag=.true.)
     write (u, *)
 
     on_shell_limit = 10._default
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit =", on_shell_limit
     call prc_set%set_on_shell_limit (on_shell_limit)
     call prc_set%determine_on_shell_histories (1, i_array)
     call prc_set%compute_probabilities (prob_array)
     write (u, "(1x,A,9(1x,"// FMT_12 // "))")  "resonant =", prob_array
     call prc_set%write (u, testflag=.true.)
     write (u, *)
 
     on_shell_limit = 10000._default
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit =", on_shell_limit
     call prc_set%set_on_shell_limit (on_shell_limit)
     call prc_set%determine_on_shell_histories (1, i_array)
     call prc_set%compute_probabilities (prob_array)
     write (u, "(1x,A,9(1x,"// FMT_12 // "))")  "resonant =", prob_array
     write (u, *)
     call prc_set%write (u, testflag=.true.)
     write (u, *)
 
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_phs_forest_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: restricted_subprocesses_3"
 
   end subroutine restricted_subprocesses_3
 
 @ %def restricted_subprocesses_3
 @
 \subsubsection{Event transform}
 Prepare an actual process with resonant subprocesses.  Prepare the
 resonance selector for a fixed event and apply the resonance-insertion
 event transform.
 <<Restricted subprocesses: execute tests>>=
   call test (restricted_subprocesses_4, "restricted_subprocesses_4", &
        "event transform", &
        u, results)
 <<Restricted subprocesses: test declarations>>=
   public :: restricted_subprocesses_4
 <<Restricted subprocesses: tests>>=
   subroutine restricted_subprocesses_4 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     class(model_t), pointer :: model
     class(model_data_t), pointer :: model_data
     type(string_t) :: libname, libname_res
     type(string_t) :: procname
     type(process_component_def_t), pointer :: process_component_def
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     logical :: exist
     type(process_t), pointer :: process
     type(process_instance_t), target :: process_instance
     type(resonance_history_set_t), dimension(1) :: res_history_set
     type(resonant_subprocess_set_t) :: prc_set
     type(particle_set_t) :: pset
     real(default) :: sqrts, mw, pp
     real(default), dimension(3) :: p3
     type(vector4_t), dimension(:), allocatable :: p
     real(default), dimension(:), allocatable :: m
     integer, dimension(:), allocatable :: pdg
     real(default) :: on_shell_limit
     type(evt_trivial_t), target :: evt_trivial
     type(evt_resonance_t), target :: evt_resonance
     real(default) :: probability
     integer :: i
 
     write (u, "(A)")  "* Test output: restricted_subprocesses_4"
     write (u, "(A)")  "*   Purpose: employ event transform"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%set_log (var_str ("?resonance_history"), &
          .true., is_known = .true.)
 
     call global%select_model (var_str ("SM"))
     allocate (model)
     call model%init_instance (global%model)
     model_data => model
 
     libname = "restricted_subprocesses_4_lib"
     libname_res = "restricted_subprocesses_4_lib_res"
     procname = "restricted_subprocesses_4_p"
 
     write (u, "(A)")  "* Initialize process library and process"
     write (u, "(A)")
 
     allocate (lib_entry)
     call lib_entry%init (libname)
     lib => lib_entry%process_library_t
     call global%add_prclib (lib_entry)
 
     call prepare_resonance_test_library &
          (lib, libname, procname, model_data, global, u)
 
     call integrate_process (procname, global, &
          local_stack = .true., init_only = .true.)
 
     process => global%process_stack%get_process_ptr (procname)
 
     call process_instance%init (process)
     call process_instance%setup_event_data ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract resonance history set"
 
     call process%extract_resonance_history_set &
          (res_history_set(1), include_trivial=.false., i_component=1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build resonant-subprocess library"
 
     call prc_set%init (1)
     call prc_set%fill_resonances (res_history_set(1), 1)
 
     process_component_def => process%get_component_def_ptr (1)
     call prc_set%create_library (libname_res, global, exist)
     if (.not. exist) then
        call prc_set%add_to_library (1, &
             process_component_def%get_prt_spec_in (), &
             process_component_def%get_prt_spec_out (), &
             global)
     end if
     call prc_set%freeze_library (global)
     call prc_set%compile_library (global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build particle set"
     write (u, "(A)")
 
     sqrts = global%get_rval (var_str ("sqrts"))
     mw = 80._default   ! deliberately slightly different from true mw
     pp = sqrt (sqrts**2 - 4 * mw**2) / 2
 
     allocate (pdg (5), p (5), m (5))
     pdg(1) = -11
     p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
     m(1) = 0
     pdg(2) = 11
     p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
     m(2) = 0
     pdg(3) = 1
     p3(1) = pp/2
     p3(2) = mw/2
     p3(3) = 0
     p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(3) = 0
     p3(2) = -mw/2
     pdg(4) = -2
     p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(4) = 0
     pdg(5) = 24
     p(5) = vector4_moving (sqrts/2,-pp, 1)
     m(5) = mw
 
     call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
     call pset%set_momentum (p, m**2)
 
     write (u, "(A)")  "* Fill process instance"
     write (u, "(A)")
 
     ! workflow from event_recalculate
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1)
     call process_instance%recover &
          (1, 1, update_sqme=.true., recover_phs=.false.)
     call process_instance%evaluate_event_data (weight = 1._default)
 
     write (u, "(A)")  "* Prepare resonant subprocesses"
     write (u, "(A)")
 
     call prc_set%prepare_process_objects (global)
     call prc_set%prepare_process_instances (global)
 
     write (u, "(A)")  "* Fill trivial event transform (deliberately w/o color)"
     write (u, "(A)")
 
     call evt_trivial%connect (process_instance, model)
     call evt_trivial%set_particle_set (pset, 1, 1)
     call evt_trivial%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize resonance-insertion event transform"
     write (u, "(A)")
 
     evt_trivial%next => evt_resonance
     evt_resonance%previous => evt_trivial
 
     call evt_resonance%set_resonance_data (res_history_set)
     call evt_resonance%select_component (1)
     call evt_resonance%connect (process_instance, model)
     call prc_set%connect_transform (evt_resonance)
     call evt_resonance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute probabilities for applicable resonances"
     write (u, "(A)")  "  and initialize the process selector"
     write (u, "(A)")
 
     on_shell_limit = 10._default
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit =", on_shell_limit
     call evt_resonance%set_on_shell_limit (on_shell_limit)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate resonance-insertion event transform"
     write (u, "(A)")
 
     call evt_resonance%prepare_new_event (1, 1)
     call evt_resonance%generate_weighted (probability)
     call evt_resonance%make_particle_set (1, .false.)
 
     call evt_resonance%write (u, testflag=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_phs_forest_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: restricted_subprocesses_4"
 
   end subroutine restricted_subprocesses_4
 
 @ %def restricted_subprocesses_4
 @
 \subsubsection{Gaussian turnoff}
 Identical to the previous process, except that we apply a Gaussian
 turnoff to the resonance kinematics, which affects the subprocess selector.
 <<Restricted subprocesses: execute tests>>=
   call test (restricted_subprocesses_5, "restricted_subprocesses_5", &
        "event transform with gaussian turnoff", &
        u, results)
 <<Restricted subprocesses: test declarations>>=
   public :: restricted_subprocesses_5
 <<Restricted subprocesses: tests>>=
   subroutine restricted_subprocesses_5 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     class(model_t), pointer :: model
     class(model_data_t), pointer :: model_data
     type(string_t) :: libname, libname_res
     type(string_t) :: procname
     type(process_component_def_t), pointer :: process_component_def
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     logical :: exist
     type(process_t), pointer :: process
     type(process_instance_t), target :: process_instance
     type(resonance_history_set_t), dimension(1) :: res_history_set
     type(resonant_subprocess_set_t) :: prc_set
     type(particle_set_t) :: pset
     real(default) :: sqrts, mw, pp
     real(default), dimension(3) :: p3
     type(vector4_t), dimension(:), allocatable :: p
     real(default), dimension(:), allocatable :: m
     integer, dimension(:), allocatable :: pdg
     real(default) :: on_shell_limit
     real(default) :: on_shell_turnoff
     type(evt_trivial_t), target :: evt_trivial
     type(evt_resonance_t), target :: evt_resonance
     real(default) :: probability
     integer :: i
 
     write (u, "(A)")  "* Test output: restricted_subprocesses_5"
     write (u, "(A)")  "*   Purpose: employ event transform &
          &with gaussian turnoff"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%set_log (var_str ("?resonance_history"), &
          .true., is_known = .true.)
 
     call global%select_model (var_str ("SM"))
     allocate (model)
     call model%init_instance (global%model)
     model_data => model
 
     libname = "restricted_subprocesses_5_lib"
     libname_res = "restricted_subprocesses_5_lib_res"
     procname = "restricted_subprocesses_5_p"
 
     write (u, "(A)")  "* Initialize process library and process"
     write (u, "(A)")
 
     allocate (lib_entry)
     call lib_entry%init (libname)
     lib => lib_entry%process_library_t
     call global%add_prclib (lib_entry)
 
     call prepare_resonance_test_library &
          (lib, libname, procname, model_data, global, u)
 
     call integrate_process (procname, global, &
          local_stack = .true., init_only = .true.)
 
     process => global%process_stack%get_process_ptr (procname)
 
     call process_instance%init (process)
     call process_instance%setup_event_data ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract resonance history set"
 
     call process%extract_resonance_history_set &
          (res_history_set(1), include_trivial=.false., i_component=1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build resonant-subprocess library"
 
     call prc_set%init (1)
     call prc_set%fill_resonances (res_history_set(1), 1)
 
     process_component_def => process%get_component_def_ptr (1)
     call prc_set%create_library (libname_res, global, exist)
     if (.not. exist) then
        call prc_set%add_to_library (1, &
             process_component_def%get_prt_spec_in (), &
             process_component_def%get_prt_spec_out (), &
             global)
     end if
     call prc_set%freeze_library (global)
     call prc_set%compile_library (global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build particle set"
     write (u, "(A)")
 
     sqrts = global%get_rval (var_str ("sqrts"))
     mw = 80._default   ! deliberately slightly different from true mw
     pp = sqrt (sqrts**2 - 4 * mw**2) / 2
 
     allocate (pdg (5), p (5), m (5))
     pdg(1) = -11
     p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
     m(1) = 0
     pdg(2) = 11
     p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
     m(2) = 0
     pdg(3) = 1
     p3(1) = pp/2
     p3(2) = mw/2
     p3(3) = 0
     p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(3) = 0
     p3(2) = -mw/2
     pdg(4) = -2
     p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(4) = 0
     pdg(5) = 24
     p(5) = vector4_moving (sqrts/2,-pp, 1)
     m(5) = mw
 
     call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
     call pset%set_momentum (p, m**2)
 
     write (u, "(A)")  "* Fill process instance"
     write (u, "(A)")
 
     ! workflow from event_recalculate
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1)
     call process_instance%recover &
          (1, 1, update_sqme=.true., recover_phs=.false.)
     call process_instance%evaluate_event_data (weight = 1._default)
 
     write (u, "(A)")  "* Prepare resonant subprocesses"
     write (u, "(A)")
 
     call prc_set%prepare_process_objects (global)
     call prc_set%prepare_process_instances (global)
 
     write (u, "(A)")  "* Fill trivial event transform (deliberately w/o color)"
     write (u, "(A)")
 
     call evt_trivial%connect (process_instance, model)
     call evt_trivial%set_particle_set (pset, 1, 1)
     call evt_trivial%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize resonance-insertion event transform"
     write (u, "(A)")
 
     evt_trivial%next => evt_resonance
     evt_resonance%previous => evt_trivial
 
     call evt_resonance%set_resonance_data (res_history_set)
     call evt_resonance%select_component (1)
     call evt_resonance%connect (process_instance, model)
     call prc_set%connect_transform (evt_resonance)
     call evt_resonance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute probabilities for applicable resonances"
     write (u, "(A)")  "  and initialize the process selector"
     write (u, "(A)")
 
     on_shell_limit = 10._default
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_limit   =", &
          on_shell_limit
     call evt_resonance%set_on_shell_limit (on_shell_limit)
 
     on_shell_turnoff = 1._default
     write (u, "(1x,A,1x," // FMT_10 // ")")  "on_shell_turnoff =", &
          on_shell_turnoff
     call evt_resonance%set_on_shell_turnoff (on_shell_turnoff)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate resonance-insertion event transform"
     write (u, "(A)")
 
     call evt_resonance%prepare_new_event (1, 1)
     call evt_resonance%generate_weighted (probability)
     call evt_resonance%make_particle_set (1, .false.)
 
     call evt_resonance%write (u, testflag=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_phs_forest_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: restricted_subprocesses_5"
 
   end subroutine restricted_subprocesses_5
 
 @ %def restricted_subprocesses_5
 @
 \subsubsection{Event transform}
 The same process and event again.  This time, switch off the background
 contribution, so the selector becomes trivial.
 <<Restricted subprocesses: execute tests>>=
   call test (restricted_subprocesses_6, "restricted_subprocesses_6", &
        "event transform with background switched off", &
        u, results)
 <<Restricted subprocesses: test declarations>>=
   public :: restricted_subprocesses_6
 <<Restricted subprocesses: tests>>=
   subroutine restricted_subprocesses_6 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     class(model_t), pointer :: model
     class(model_data_t), pointer :: model_data
     type(string_t) :: libname, libname_res
     type(string_t) :: procname
     type(process_component_def_t), pointer :: process_component_def
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     logical :: exist
     type(process_t), pointer :: process
     type(process_instance_t), target :: process_instance
     type(resonance_history_set_t), dimension(1) :: res_history_set
     type(resonant_subprocess_set_t) :: prc_set
     type(particle_set_t) :: pset
     real(default) :: sqrts, mw, pp
     real(default), dimension(3) :: p3
     type(vector4_t), dimension(:), allocatable :: p
     real(default), dimension(:), allocatable :: m
     integer, dimension(:), allocatable :: pdg
     real(default) :: on_shell_limit
     real(default) :: background_factor
     type(evt_trivial_t), target :: evt_trivial
     type(evt_resonance_t), target :: evt_resonance
     real(default) :: probability
     integer :: i
 
     write (u, "(A)")  "* Test output: restricted_subprocesses_6"
     write (u, "(A)")  "*   Purpose: employ event transform &
          &with background switched off"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%set_log (var_str ("?resonance_history"), &
          .true., is_known = .true.)
 
     call global%select_model (var_str ("SM"))
     allocate (model)
     call model%init_instance (global%model)
     model_data => model
 
     libname = "restricted_subprocesses_6_lib"
     libname_res = "restricted_subprocesses_6_lib_res"
     procname = "restricted_subprocesses_6_p"
 
     write (u, "(A)")  "* Initialize process library and process"
     write (u, "(A)")
 
     allocate (lib_entry)
     call lib_entry%init (libname)
     lib => lib_entry%process_library_t
     call global%add_prclib (lib_entry)
 
     call prepare_resonance_test_library &
          (lib, libname, procname, model_data, global, u)
 
     call integrate_process (procname, global, &
          local_stack = .true., init_only = .true.)
 
     process => global%process_stack%get_process_ptr (procname)
 
     call process_instance%init (process)
     call process_instance%setup_event_data ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract resonance history set"
 
     call process%extract_resonance_history_set &
          (res_history_set(1), include_trivial=.false., i_component=1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build resonant-subprocess library"
 
     call prc_set%init (1)
     call prc_set%fill_resonances (res_history_set(1), 1)
 
     process_component_def => process%get_component_def_ptr (1)
     call prc_set%create_library (libname_res, global, exist)
     if (.not. exist) then
        call prc_set%add_to_library (1, &
             process_component_def%get_prt_spec_in (), &
             process_component_def%get_prt_spec_out (), &
             global)
     end if
     call prc_set%freeze_library (global)
     call prc_set%compile_library (global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build particle set"
     write (u, "(A)")
 
     sqrts = global%get_rval (var_str ("sqrts"))
     mw = 80._default   ! deliberately slightly different from true mw
     pp = sqrt (sqrts**2 - 4 * mw**2) / 2
 
     allocate (pdg (5), p (5), m (5))
     pdg(1) = -11
     p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
     m(1) = 0
     pdg(2) = 11
     p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
     m(2) = 0
     pdg(3) = 1
     p3(1) = pp/2
     p3(2) = mw/2
     p3(3) = 0
     p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(3) = 0
     p3(2) = -mw/2
     pdg(4) = -2
     p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(4) = 0
     pdg(5) = 24
     p(5) = vector4_moving (sqrts/2,-pp, 1)
     m(5) = mw
 
     call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
     call pset%set_momentum (p, m**2)
 
     write (u, "(A)")  "* Fill process instance"
     write (u, "(A)")
 
     ! workflow from event_recalculate
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1)
     call process_instance%recover &
          (1, 1, update_sqme=.true., recover_phs=.false.)
     call process_instance%evaluate_event_data (weight = 1._default)
 
     write (u, "(A)")  "* Prepare resonant subprocesses"
     write (u, "(A)")
 
     call prc_set%prepare_process_objects (global)
     call prc_set%prepare_process_instances (global)
 
     write (u, "(A)")  "* Fill trivial event transform (deliberately w/o color)"
     write (u, "(A)")
 
     call evt_trivial%connect (process_instance, model)
     call evt_trivial%set_particle_set (pset, 1, 1)
     call evt_trivial%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize resonance-insertion event transform"
     write (u, "(A)")
 
     evt_trivial%next => evt_resonance
     evt_resonance%previous => evt_trivial
 
     call evt_resonance%set_resonance_data (res_history_set)
     call evt_resonance%select_component (1)
     call evt_resonance%connect (process_instance, model)
     call prc_set%connect_transform (evt_resonance)
     call evt_resonance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute probabilities for applicable resonances"
     write (u, "(A)")  "  and initialize the process selector"
     write (u, "(A)")
 
     on_shell_limit = 10._default
     write (u, "(1x,A,1x," // FMT_10 // ")") &
          "on_shell_limit    =", on_shell_limit
     call evt_resonance%set_on_shell_limit (on_shell_limit)
 
     background_factor = 0
     write (u, "(1x,A,1x," // FMT_10 // ")") &
          "background_factor =", background_factor
     call evt_resonance%set_background_factor (background_factor)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate resonance-insertion event transform"
     write (u, "(A)")
 
     call evt_resonance%prepare_new_event (1, 1)
     call evt_resonance%generate_weighted (probability)
     call evt_resonance%make_particle_set (1, .false.)
 
     call evt_resonance%write (u, testflag=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
     call syntax_phs_forest_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: restricted_subprocesses_6"
 
   end subroutine restricted_subprocesses_6
 
 @ %def restricted_subprocesses_6
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Simulation}
 This module manages simulation: event generation and reading/writing of event
 files.  The [[simulation]] object is intended to be used (via a pointer)
 outside of \whizard, if events are generated individually by an external
 driver.
 <<[[simulations.f90]]>>=
 <<File header>>
 
 module simulations
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use format_utils, only: write_separator
   use format_defs, only: FMT_15, FMT_19
   use os_interface
   use numeric_utils
   use string_utils, only: str
   use diagnostics
   use lorentz, only: vector4_t
   use sm_qcd
   use md5
   use variables, only: var_list_t
   use eval_trees
   use model_data
   use flavors
   use particles
   use state_matrices, only: FM_IGNORE_HELICITY
   use beam_structures, only: beam_structure_t
   use beams
   use rng_base
   use rng_stream, only: rng_stream_t
   use selectors
   use resonances, only: resonance_history_set_t
   use process_libraries, only: process_library_t
   use process_libraries, only: process_component_def_t
   use prc_core
   !  TODO: (bcn 2016-09-13) should be ideally only pcm_base
   use pcm, only: pcm_nlo_t, pcm_instance_nlo_t
   !  TODO: (bcn 2016-09-13) details of process config should not be necessary here
   use process_config, only: COMP_REAL_FIN
   use process
   use instances
   use event_base
   use event_handles, only: event_handle_t
   use events
   use event_transforms
   use shower
   use eio_data
   use eio_base
   use rt_data
 
   use dispatch_beams, only: dispatch_qcd
   use dispatch_rng, only: dispatch_rng_factory
   use dispatch_rng, only: update_rng_seed_in_var_list
   use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore
   use dispatch_transforms, only: dispatch_evt_isr_epa_handler
   use dispatch_transforms, only: dispatch_evt_resonance
   use dispatch_transforms, only: dispatch_evt_decay
   use dispatch_transforms, only: dispatch_evt_shower
   use dispatch_transforms, only: dispatch_evt_hadrons
   use dispatch_transforms, only: dispatch_evt_nlo
 
   use integrations
   use event_streams
   use restricted_subprocesses, only: resonant_subprocess_set_t
   use restricted_subprocesses, only: get_libname_res
 
   use evt_nlo
 
 <<Use mpi f08>>
 
 <<Standard module head>>
 
 <<Simulations: public>>
 
 <<Simulations: types>>
 
 <<Simulations: interfaces>>
 
 contains
 
 <<Simulations: procedures>>
 
 end module simulations
 @ %def simulations
 @
 \subsection{Event counting}
 In this object we collect statistical information about an event
 sample or sub-sample.
 <<Simulations: types>>=
   type :: counter_t
      integer :: total = 0
      integer :: generated = 0
      integer :: read = 0
      integer :: positive = 0
      integer :: negative = 0
      integer :: zero = 0
      integer :: excess = 0
      integer :: dropped = 0
      real(default) :: max_excess = 0
      real(default) :: sum_excess = 0
      logical :: reproduce_xsection = .false.
      real(default) :: mean = 0
      real(default) :: varsq = 0
      integer :: nlo_weight_counter = 0
    contains
    <<Simulations: counter: TBP>>
   end type counter_t
 
 @ %def simulation_counter_t
 @ Output.
 <<Simulations: counter: TBP>>=
   procedure :: write => counter_write
 <<Simulations: procedures>>=
   subroutine counter_write (counter, unit)
     class(counter_t), intent(in) :: counter
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
 1   format (3x,A,I0)
 2   format (5x,A,I0)
 3   format (5x,A,ES19.12)
     write (u, 1)  "Events total      = ", counter%total
     write (u, 2)  "generated       = ", counter%generated
     write (u, 2)  "read            = ", counter%read
     write (u, 2)  "positive weight = ", counter%positive
     write (u, 2)  "negative weight = ", counter%negative
     write (u, 2)  "zero weight     = ", counter%zero
     write (u, 2)  "excess weight   = ", counter%excess
     if (counter%excess /= 0) then
        write (u, 3)  "max excess      = ", counter%max_excess
        write (u, 3)  "avg excess      = ", counter%sum_excess / counter%total
     end if
     write (u, 1)  "Events dropped    = ", counter%dropped
   end subroutine counter_write
 
 @ %def counter_write
 @ This is a screen message: if there was an excess, display statistics.
 <<Simulations: counter: TBP>>=
   procedure :: show_excess => counter_show_excess
 <<Simulations: procedures>>=
   subroutine counter_show_excess (counter)
     class(counter_t), intent(in) :: counter
     if (counter%excess > 0) then
        write (msg_buffer, "(A,1x,I0,1x,A,1x,'(',F7.3,' %)')") &
             "Encountered events with excess weight:", counter%excess, &
             "events", 100 * counter%excess / real (counter%total)
        call msg_warning ()
        write (msg_buffer, "(A,ES10.3)") &
             "Maximum excess weight =", counter%max_excess
        call msg_message ()
        write (msg_buffer, "(A,ES10.3)") &
             "Average excess weight =", counter%sum_excess / counter%total
        call msg_message ()
     end if
   end subroutine counter_show_excess
 
 @ %def counter_show_excess
 @ If events have been dropped during simulation of weighted events,
 issue a message here.
 If a fraction [[n_dropped / n_total]] of the events fail the cuts, we keep
 generating new ones until we have [[n_total]] events with [[weight > 0]].
 Thus, the total sum of weights will be a fraction of [[n_dropped / n_total]]
 too large. However, we do not know how many events will pass or fail the cuts
 prior to generating them so we leave it to the user to correct for this factor.
 <<Simulations: counter: TBP>>=
   procedure :: show_dropped => counter_show_dropped
 <<Simulations: procedures>>=
   subroutine counter_show_dropped (counter)
     class(counter_t), intent(in) :: counter
     if (counter%dropped > 0) then
        write (msg_buffer, "(A,1x,I0,1x,'(',A,1x,I0,')')") &
             "Dropped events (weight zero) =", &
             counter%dropped, "total", counter%dropped + counter%total
        call msg_message ()
        write (msg_buffer, "(A,ES15.8)") &
             "All event weights must be rescaled by f =", &
             real (counter%total, default) &
             / real (counter%dropped + counter%total, default)
        call msg_warning ()
     end if
   end subroutine counter_show_dropped
 
 @ %def counter_show_dropped
 @
 <<Simulations: counter: TBP>>=
   procedure :: show_mean_and_variance => counter_show_mean_and_variance
 <<Simulations: procedures>>=
   subroutine counter_show_mean_and_variance (counter)
     class(counter_t), intent(in) :: counter
     if (counter%reproduce_xsection .and. counter%nlo_weight_counter > 1) then
        print *,  "Reconstructed cross-section from event weights: "
        print *,  counter%mean, '+-', sqrt (counter%varsq / (counter%nlo_weight_counter - 1))
     end if
   end subroutine counter_show_mean_and_variance
 
 @ %def counter_show_mean_and_variance
 @ Count an event.  The weight and event source are optional; by
 default we assume that the event has been generated and has positive
 weight.
 
 The optional integer [[n_dropped]] counts weighted events with weight
 zero that were encountered while generating the current event, but
 dropped (because of their zero weight).  Accumulating this number
 allows for renormalizing event weight sums in histograms, after the
 generation step has been completed.
 <<Simulations: counter: TBP>>=
   procedure :: record => counter_record
 <<Simulations: procedures>>=
   subroutine counter_record (counter, weight, excess, n_dropped, from_file)
     class(counter_t), intent(inout) :: counter
     real(default), intent(in), optional :: weight, excess
     integer, intent(in), optional :: n_dropped
     logical, intent(in), optional :: from_file
     counter%total = counter%total + 1
     if (present (from_file)) then
        if (from_file) then
           counter%read = counter%read + 1
        else
           counter%generated = counter%generated + 1
        end if
     else
        counter%generated = counter%generated + 1
     end if
     if (present (weight)) then
        if (weight > 0) then
           counter%positive = counter%positive + 1
        else if (weight < 0) then
           counter%negative = counter%negative + 1
        else
           counter%zero = counter%zero + 1
        end if
     else
        counter%positive = counter%positive + 1
     end if
     if (present (excess)) then
        if (excess > 0) then
           counter%excess = counter%excess + 1
           counter%max_excess = max (counter%max_excess, excess)
           counter%sum_excess = counter%sum_excess + excess
        end if
     end if
     if (present (n_dropped)) then
        counter%dropped = counter%dropped + n_dropped
     end if
   end subroutine counter_record
 
 @ %def counter_record
 <<MPI: Simulations: counter: TBP>>=
   procedure :: allreduce_record => counter_allreduce_record
 <<MPI: Simulations: procedures>>=
   subroutine counter_allreduce_record (counter)
     class(counter_t), intent(inout) :: counter
     integer :: read, generated
     integer :: positive, negative, zero, excess, dropped
     real(default) :: max_excess, sum_excess
     read = counter%read
     generated = counter%generated
     positive = counter%positive
     negative = counter%negative
     zero = counter%zero
     excess = counter%excess
     max_excess = counter%max_excess
     sum_excess = counter%sum_excess
     dropped = counter%dropped
     call MPI_ALLREDUCE (read, counter%read, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
     call MPI_ALLREDUCE (generated, counter%generated, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
     call MPI_ALLREDUCE (positive, counter%positive, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
     call MPI_ALLREDUCE (negative, counter%negative, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
     call MPI_ALLREDUCE (zero, counter%zero, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
     call MPI_ALLREDUCE (excess, counter%excess, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
     call MPI_ALLREDUCE (max_excess, counter%max_excess, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD)
     call MPI_ALLREDUCE (sum_excess, counter%sum_excess, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD)
     call MPI_ALLREDUCE (dropped, counter%dropped, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
     !! \todo{sbrass - Implement allreduce of mean and variance, relevant for weighted events.}
   end subroutine counter_allreduce_record
 
 @
 <<Simulations: counter: TBP>>=
   procedure :: record_mean_and_variance => &
      counter_record_mean_and_variance
 <<Simulations: procedures>>=
   subroutine counter_record_mean_and_variance (counter, weight, i_nlo)
     class(counter_t), intent(inout) :: counter
     real(default), intent(in) :: weight
     integer, intent(in) :: i_nlo
     real(default), save :: weight_buffer = 0._default
     integer, save :: nlo_count = 1
     if (.not. counter%reproduce_xsection) return
     if (i_nlo == 1) then
        call flush_weight_buffer (weight_buffer, nlo_count)
        weight_buffer = weight
        nlo_count = 1
     else
        weight_buffer = weight_buffer + weight
        nlo_count = nlo_count + 1
     end if
   contains
     subroutine flush_weight_buffer (w, n_nlo)
       real(default), intent(in) :: w
       integer, intent(in) :: n_nlo
       integer :: n
       real(default) :: mean_new
       counter%nlo_weight_counter = counter%nlo_weight_counter + 1
       !!! Minus 1 to take into account offset from initialization
       n = counter%nlo_weight_counter - 1
       if (n > 0) then
          mean_new = counter%mean + (w / n_nlo - counter%mean) / n
          if (n > 1) &
             counter%varsq = counter%varsq - counter%varsq / (n - 1) + &
                n * (mean_new - counter%mean)**2
          counter%mean = mean_new
       end if
     end subroutine flush_weight_buffer
   end subroutine counter_record_mean_and_variance
 
 @ %def counter_record_mean_and_variance
 @
 \subsection{Simulation: component sets}
 For each set of process components that share a MCI entry in the
 process configuration, we keep a separate event record.
 <<Simulations: types>>=
   type :: mci_set_t
      private
      integer :: n_components = 0
      integer, dimension(:), allocatable :: i_component
      type(string_t), dimension(:), allocatable :: component_id
      logical :: has_integral = .false.
      real(default) :: integral = 0
      real(default) :: error = 0
      real(default) :: weight_mci = 0
      type(counter_t) :: counter
    contains
    <<Simulations: mci set: TBP>>
   end type mci_set_t
 
 @ %def mci_set_t
 @ Output.
 <<Simulations: mci set: TBP>>=
   procedure :: write => mci_set_write
 <<Simulations: procedures>>=
   subroutine mci_set_write (object, unit, pacified)
     class(mci_set_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: pacified
     logical :: pacify
     integer :: u, i
     u = given_output_unit (unit)
     pacify = .false.;  if (present (pacified))  pacify = pacified
     write (u, "(3x,A)")  "Components:"
     do i = 1, object%n_components
        write (u, "(5x,I0,A,A,A)")  object%i_component(i), &
             ": '", char (object%component_id(i)), "'"
     end do
     if (object%has_integral) then
        if (pacify) then
           write (u, "(3x,A," // FMT_15 // ")")  "Integral  = ", object%integral
           write (u, "(3x,A," // FMT_15 // ")")  "Error     = ", object%error
           write (u, "(3x,A,F9.6)")  "Weight    =", object%weight_mci
        else
           write (u, "(3x,A," // FMT_19 // ")")  "Integral  = ", object%integral
           write (u, "(3x,A," // FMT_19 // ")")  "Error     = ", object%error
           write (u, "(3x,A,F13.10)")  "Weight    =", object%weight_mci
        end if
     else
        write (u, "(3x,A)")  "Integral  = [undefined]"
     end if
     call object%counter%write (u)
   end subroutine mci_set_write
 
 @ %def mci_set_write
 @ Initialize: Get the indices and names for the process components
 that will contribute to this set.
 <<Simulations: mci set: TBP>>=
   procedure :: init => mci_set_init
 <<Simulations: procedures>>=
   subroutine mci_set_init (object, i_mci, process)
     class(mci_set_t), intent(out) :: object
     integer, intent(in) :: i_mci
     type(process_t), intent(in), target :: process
     integer :: i
     call process%get_i_component (i_mci, object%i_component)
     object%n_components = size (object%i_component)
     allocate (object%component_id (object%n_components))
     do i = 1, size (object%component_id)
        object%component_id(i) = &
             process%get_component_id (object%i_component(i))
     end do
     if (process%has_integral (i_mci)) then
        object%integral = process%get_integral (i_mci)
        object%error = process%get_error (i_mci)
        object%has_integral = .true.
     end if
   end subroutine mci_set_init
 
 @ %def mci_set_init
 @
 \subsection{Process-core Safe}
 This is an object that temporarily holds a process core object.  We
 need this while rescanning a process with modified parameters.  After
 the rescan, we want to restore the original state.
 <<Simulations: types>>=
   type :: core_safe_t
      class(prc_core_t), allocatable :: core
   end type core_safe_t
 
 @ %def core_safe_t
 @
 \subsection{Process Object}
 The simulation works on process objects.  This subroutine makes a
 process object available for simulation.  The process is in the
 process stack.  [[use_process]] implies that the process should
 already exist as an object in the process stack.  If integration is
 not yet done, do it.  Any generated process object should be put on
 the global stack, if it is separate from the local one.
 <<Simulations: procedures>>=
   subroutine prepare_process &
        (process, process_id, use_process, integrate, local, global)
     type(process_t), pointer, intent(out) :: process
     type(string_t), intent(in) :: process_id
     logical, intent(in) :: use_process, integrate
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), optional, target :: global
     type(rt_data_t), pointer :: current
     if (debug_on) call msg_debug (D_CORE, "prepare_process")
     if (debug_on) call msg_debug (D_CORE, "global present", present (global))
     if (present (global)) then
        current => global
     else
        current => local
     end if
     process => current%process_stack%get_process_ptr (process_id)
     if (debug_on) call msg_debug (D_CORE, "use_process", use_process)
     if (debug_on) call msg_debug (D_CORE, "associated process", associated (process))
     if (use_process .and. .not. associated (process)) then
        if (integrate) then
           call msg_message ("Simulate: process '" &
                // char (process_id) // "' needs integration")
        else
           call msg_message ("Simulate: process '" &
                // char (process_id) // "' needs initialization")
        end if
        if (present (global)) then
           call integrate_process (process_id, local, global, &
             init_only = .not. integrate)
        else
           call integrate_process (process_id, local, &
                local_stack = .true., init_only = .not. integrate)
        end if
        if (signal_is_pending ())  return
        process => current%process_stack%get_process_ptr (process_id)
        if (associated (process)) then
           if (integrate) then
              call msg_message ("Simulate: integration done")
              call current%process_stack%fill_result_vars (process_id)
           else
              call msg_message ("Simulate: process initialization done")
           end if
        else
           call msg_fatal ("Simulate: process '" &
                // char (process_id) // "' could not be initialized: aborting")
        end if
     else if (.not. associated (process)) then
        if (present (global)) then
           call integrate_process (process_id, local, global, &
                init_only = .true.)
        else
           call integrate_process (process_id, local, &
                local_stack = .true., init_only = .true.)
        end if
        process => current%process_stack%get_process_ptr (process_id)
        call msg_message &
             ("Simulate: process '" &
                // char (process_id) // "': enabled for rescan only")
     end if
   end subroutine prepare_process
 
 @ %def prepare_process
 @
 \subsection{Simulation-entry object}
 For each process that we consider for event generation, we need a
 separate entry.  The entry separately records the process ID and run ID.  The
 [[weight_mci]] array is used for selecting a component set (which
 shares an MCI record inside the process container) when generating an
 event for the current process.
 
 The simulation entry is an extension of the [[event_t]] event record.
 This core object contains configuration data, pointers to the process
 and process instance, the expressions, flags and values that are
 evaluated at runtime, and the resulting particle set.
 
 The entry explicitly allocates the [[process_instance]], which becomes
 the process-specific workspace for the event record.
 
 If entries with differing environments are present simultaneously, we
 may need to switch QCD parameters and/or the model event by event.  In
 this case, the [[qcd]] and/or [[model]] components are present.
 
 For the purpose of NLO events, [[entry_t]] contains a pointer list
 to other simulation-entries. This is due to the fact that we have to
 associate an event for each component of the fixed order simulation,
 i.e. one $N$-particle event and $N_\text{phs}$ $N+1$-particle events.
 However, all entries share the same event transforms.
 <<Simulations: types>>=
   type, extends (event_t) :: entry_t
      private
      type(string_t) :: process_id
      type(string_t) :: library
      type(string_t) :: run_id
      logical :: has_integral = .false.
      real(default) :: integral = 0
      real(default) :: error = 0
      real(default) :: process_weight = 0
      logical :: valid = .false.
      type(counter_t) :: counter
      integer :: n_in = 0
      integer :: n_mci = 0
      type(mci_set_t), dimension(:), allocatable :: mci_sets
      type(selector_t) :: mci_selector
      logical :: has_resonant_subprocess_set = .false.
      type(resonant_subprocess_set_t) :: resonant_subprocess_set
      type(core_safe_t), dimension(:), allocatable :: core_safe
      class(model_data_t), pointer :: model => null ()
      type(qcd_t) :: qcd
      type(entry_t), pointer :: first => null ()
      type(entry_t), pointer :: next => null ()
      class(evt_t), pointer :: evt_powheg => null ()
    contains
    <<Simulations: entry: TBP>>
   end type entry_t
 
 @ %def entry_t
 @ Output.  Write just the configuration, the event is written by a
 separate routine.
 
 The [[verbose]] option is unused, it is required by the interface of
 the base-object method.
 <<Simulations: entry: TBP>>=
   procedure :: write_config => entry_write_config
 <<Simulations: procedures>>=
   subroutine entry_write_config (object, unit, pacified)
     class(entry_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: pacified
     logical :: pacify
     integer :: u, i
     u = given_output_unit (unit)
     pacify = .false.;  if (present (pacified))  pacify = pacified
     write (u, "(3x,A,A,A)")  "Process   = '", char (object%process_id), "'"
     write (u, "(3x,A,A,A)")  "Library   = '", char (object%library), "'"
     write (u, "(3x,A,A,A)")  "Run       = '", char (object%run_id), "'"
     write (u, "(3x,A,L1)")   "is valid  = ", object%valid
     if (object%has_integral) then
        if (pacify) then
           write (u, "(3x,A," // FMT_15 // ")")  "Integral  = ", object%integral
           write (u, "(3x,A," // FMT_15 // ")")  "Error     = ", object%error
           write (u, "(3x,A,F9.6)")  "Weight    =", object%process_weight
        else
           write (u, "(3x,A," // FMT_19 // ")")  "Integral  = ", object%integral
           write (u, "(3x,A," // FMT_19 // ")")  "Error     = ", object%error
           write (u, "(3x,A,F13.10)")  "Weight    =", object%process_weight
        end if
     else
        write (u, "(3x,A)")  "Integral  = [undefined]"
     end if
     write (u, "(3x,A,I0)")   "MCI sets  = ", object%n_mci
     call object%counter%write (u)
     do i = 1, size (object%mci_sets)
        write (u, "(A)")
        write (u, "(1x,A,I0,A)")  "MCI set #", i, ":"
        call object%mci_sets(i)%write (u, pacified)
     end do
     if (object%resonant_subprocess_set%is_active ()) then
        write (u, "(A)")
        call object%write_resonant_subprocess_data (u)
     end if
     if (allocated (object%core_safe)) then
        do i = 1, size (object%core_safe)
           write (u, "(1x,A,I0,A)")  "Saved process-component core #", i, ":"
           call object%core_safe(i)%core%write (u)
        end do
     end if
   end subroutine entry_write_config
 
 @ %def entry_write_config
 @ Finalizer.  The [[instance]] pointer component of the [[event_t]]
 base type points to a target which we did explicitly allocate in the
 [[entry_init]] procedure.  Therefore, we finalize and explicitly
 deallocate it here.  Then we call the finalizer of the base type.
 <<Simulations: entry: TBP>>=
   procedure :: final => entry_final
 <<Simulations: procedures>>=
   subroutine entry_final (object)
     class(entry_t), intent(inout) :: object
     integer :: i
     if (associated (object%instance)) then
        do i = 1, object%n_mci
           call object%instance%final_simulation (i)
        end do
        call object%instance%final ()
        deallocate (object%instance)
     end if
     call object%event_t%final ()
   end subroutine entry_final
 
 @ %def entry_final
 @ Copy the content of an entry into another one, except for the next-pointer
 <<Simulations: entry: TBP>>=
   procedure :: copy_entry => entry_copy_entry
 <<Simulations: procedures>>=
   subroutine entry_copy_entry (entry1, entry2)
     class(entry_t), intent(in), target :: entry1
     type(entry_t), intent(inout), target :: entry2
     call entry1%event_t%clone (entry2%event_t)
     entry2%process_id = entry1%process_id
     entry2%library = entry1%library
     entry2%run_id = entry1%run_id
     entry2%has_integral = entry1%has_integral
     entry2%integral = entry1%integral
     entry2%error = entry1%error
     entry2%process_weight = entry1%process_weight
     entry2%valid = entry1%valid
     entry2%counter = entry1%counter
     entry2%n_in = entry1%n_in
     entry2%n_mci = entry1%n_mci
     if (allocated (entry1%mci_sets)) then
        allocate (entry2%mci_sets (size (entry1%mci_sets)))
        entry2%mci_sets = entry1%mci_sets
     end if
     entry2%mci_selector = entry1%mci_selector
     if (allocated (entry1%core_safe)) then
        allocate (entry2%core_safe (size (entry1%core_safe)))
        entry2%core_safe = entry1%core_safe
     end if
     entry2%model => entry1%model
     entry2%qcd = entry1%qcd
   end subroutine entry_copy_entry
 
 @ %def entry_copy_entry
 @
 \subsubsection{Simulation-entry initialization}
 Search for a process entry and allocate a process
 instance as an anonymous object, temporarily accessible via the
 [[process_instance]] pointer.  Assign data by looking at the process
 object and at the environment.
 
 If [[n_alt]] is set, we prepare for additional alternate sqme and weight
 entries.
 
 The [[compile]] flag is only false if we do not need the Whizard
 process at all, just its definition.  In that case, we skip process
 initialization.
 
 Otherwise, and if the process object is not found initially: if
 [[integrate]] is set, attempt an integration pass and try again.
 Otherwise, just initialize the object.
 
 If [[generate]] is set, prepare the MCI objects for generating new events.
 For pure rescanning, this is not necessary.
 
 If [[resonance_history]] is set, we create a separate process library
 which contains all possible restricted subprocesses with distinct
 resonance histories.  These processes will not be integrated, but
 their matrix element codes are used for determining probabilities of
 resonance histories.  Note that this can work only if the process
 method is OMega, and the phase-space method is 'wood'.
 
 When done, we assign the [[instance]] and [[process]] pointers of the
 base type by the [[connect]] method, so we can reference them later.
 
 TODO: In case of NLO event generation, copying the configuration from the
 master process is rather intransparent.  For instance, we override the process
 var list by the global var list.
 <<Simulations: entry: TBP>>=
   procedure :: init => entry_init
 <<Simulations: procedures>>=
   subroutine entry_init &
        (entry, process_id, &
        use_process, integrate, generate, update_sqme, &
        support_resonance_history, &
        local, global, n_alt)
     class(entry_t), intent(inout), target :: entry
     type(string_t), intent(in) :: process_id
     logical, intent(in) :: use_process, integrate, generate, update_sqme
     logical, intent(in) :: support_resonance_history
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), optional, target :: global
     integer, intent(in), optional :: n_alt
     type(process_t), pointer :: process, master_process
     type(process_instance_t), pointer :: process_instance
     type(process_library_t), pointer :: prclib_saved
     integer :: i
     logical :: res_include_trivial
     logical :: combined_integration
     integer :: selected_mci
     selected_mci = 0
     if (debug_on) call msg_debug (D_CORE, "entry_init")
     if (debug_on) call msg_debug (D_CORE, "process_id", process_id)
     call prepare_process &
          (master_process, process_id, use_process, integrate, local, global)
     if (signal_is_pending ())  return
 
     if (associated (master_process)) then
        if (.not. master_process%has_matrix_element ()) then
           entry%has_integral = .true.
           entry%process_id = process_id
           entry%valid = .false.
           return
        end if
     else
        call entry%basic_init (local%var_list)
        entry%has_integral = .false.
        entry%process_id = process_id
        call entry%import_process_def_characteristics (local%prclib, process_id)
        entry%valid = .true.
        return
     end if
 
     call entry%basic_init (local%var_list, n_alt)
 
     entry%process_id = process_id
     if (generate .or. integrate) then
        entry%run_id = master_process%get_run_id ()
        process => master_process
     else
        call local%set_log (var_str ("?rebuild_phase_space"), &
             .false., is_known = .true.)
        call local%set_log (var_str ("?check_phs_file"), &
             .false., is_known = .true.)
        call local%set_log (var_str ("?rebuild_grids"), &
             .false., is_known = .true.)
        entry%run_id = &
             local%var_list%get_sval (var_str ("$run_id"))
        if (update_sqme) then
           call prepare_local_process (process, process_id, local)
        else
           process => master_process
        end if
     end if
 
     call entry%import_process_characteristics (process)
 
     allocate (entry%mci_sets (entry%n_mci))
     do i = 1, size (entry%mci_sets)
        call entry%mci_sets(i)%init (i, master_process)
     end do
 
     call entry%import_process_results (master_process)
     call entry%prepare_expressions (local)
 
     if (process%is_nlo_calculation ()) then
        call process%init_nlo_settings (global%var_list)
     end if
     combined_integration = local%get_lval (var_str ("?combined_nlo_integration"))
     if (.not. combined_integration &
          .and. local%get_lval (var_str ("?fixed_order_nlo_events"))) &
               selected_mci = process%extract_active_component_mci ()
     call prepare_process_instance (process_instance, process, local%model, &
          local = local)
 
     if (generate) then
        if (selected_mci > 0) then
           call process%prepare_simulation (selected_mci)
           call process_instance%init_simulation (selected_mci, entry%config%safety_factor, &
                local%get_lval (var_str ("?keep_failed_events")))
        else
           do i = 1, entry%n_mci
              call process%prepare_simulation (i)
              call process_instance%init_simulation (i, entry%config%safety_factor, &
                   local%get_lval (var_str ("?keep_failed_events")))
           end do
       end if
     end if
 
     if (support_resonance_history) then
        prclib_saved => local%prclib
        call entry%setup_resonant_subprocesses (local, process)
        if (entry%has_resonant_subprocess_set) then
           if (signal_is_pending ())  return
           call entry%compile_resonant_subprocesses (local)
           if (signal_is_pending ())  return
           call entry%prepare_resonant_subprocesses (local, global)
           if (signal_is_pending ())  return
           call entry%prepare_resonant_subprocess_instances (local)
        end if
        if (signal_is_pending ())  return
        if (associated (prclib_saved))  call local%update_prclib (prclib_saved)
     end if
 
     call entry%setup_event_transforms (process, local)
 
     call dispatch_qcd (entry%qcd, local%get_var_list_ptr (), local%os_data)
 
     call entry%connect_qcd ()
 
     select type (pcm => process_instance%pcm)
     class is (pcm_instance_nlo_t)
         select type (config => pcm%config)
         type is (pcm_nlo_t)
            if (config%settings%fixed_order_nlo) &
                 call pcm%set_fixed_order_event_mode ()
        end select
     end select
 
     if (present (global)) then
        call entry%connect (process_instance, local%model, global%process_stack)
     else
        call entry%connect (process_instance, local%model, local%process_stack)
     end if
     call entry%setup_expressions ()
 
     entry%model => process%get_model_ptr ()
 
     entry%valid = .true.
 
   end subroutine entry_init
 
 @ %def entry_init
 @
 <<Simulations: entry: TBP>>=
   procedure :: set_active_real_components => entry_set_active_real_components
 <<Simulations: procedures>>=
   subroutine entry_set_active_real_components (entry)
     class(entry_t), intent(inout) :: entry
     integer :: i_active_real
     select type (pcm => entry%instance%pcm)
     class is (pcm_instance_nlo_t)
        i_active_real = entry%instance%get_real_of_mci ()
        if (debug_on) call msg_debug2 (D_CORE, "i_active_real", i_active_real)
        if (associated (entry%evt_powheg)) then
           select type (evt => entry%evt_powheg)
           type is (evt_shower_t)
              if (entry%process%get_component_type(i_active_real) == COMP_REAL_FIN) then
                 if (debug_on) call msg_debug (D_CORE, "Disabling Powheg matching for ", i_active_real)
                 call evt%disable_powheg_matching ()
              else
                 if (debug_on) call msg_debug (D_CORE, "Enabling Powheg matching for ", i_active_real)
                 call evt%enable_powheg_matching ()
              end if
           class default
              call msg_fatal ("powheg-evt should be evt_shower_t!")
           end select
        end if
     end select
   end subroutine entry_set_active_real_components
 
 @ %def entry_set_active_real_components
 @ Part of simulation-entry initialization: set up a process object for
 local use.
 <<Simulations: procedures>>=
   subroutine prepare_local_process (process, process_id, local)
     type(process_t), pointer, intent(inout) :: process
     type(string_t), intent(in) :: process_id
     type(rt_data_t), intent(inout), target :: local
     type(integration_t) :: intg
     call intg%create_process (process_id)
     call intg%init_process (local)
     call intg%setup_process (local, verbose=.false.)
     process => intg%get_process_ptr ()
   end subroutine prepare_local_process
 
 @ %def prepare_local_process
 @ Part of simulation-entry initialization: set up a process instance
 matching the selected process object.
 
 The model that we can provide as an extra argument can modify particle
 settings (polarization) in the density matrices that will be constructed.  It
 does not affect parameters.
 <<Simulations: procedures>>=
   subroutine prepare_process_instance &
     (process_instance, process, model, local)
     type(process_instance_t), pointer, intent(inout) :: process_instance
     type(process_t), intent(inout), target :: process
     class(model_data_t), intent(in), optional :: model
     type(rt_data_t), intent(in), optional, target :: local
     allocate (process_instance)
     call process_instance%init (process)
     if (process%is_nlo_calculation ()) then
        select type (pcm => process_instance%pcm)
        type is (pcm_instance_nlo_t)
           select type (config => pcm%config)
           type is (pcm_nlo_t)
              if (.not. config%settings%combined_integration) &
                   call pcm%set_radiation_event ()
           end select
        end select
        call process%prepare_any_external_code ()
     end if
     call process_instance%setup_event_data (model)
   end subroutine prepare_process_instance
 
 @ %def prepare_process_instance
 @ Part of simulation-entry initialization: query the
 process for basic information.
 <<Simulations: entry: TBP>>=
   procedure, private :: import_process_characteristics &
        => entry_import_process_characteristics
 <<Simulations: procedures>>=
   subroutine entry_import_process_characteristics (entry, process)
     class(entry_t), intent(inout) :: entry
     type(process_t), intent(in), target :: process
     entry%library = process%get_library_name ()
     entry%n_in = process%get_n_in ()
     entry%n_mci = process%get_n_mci ()
   end subroutine entry_import_process_characteristics
 
 @ %def entry_import_process_characteristics
 @ This is the alternative form which applies if there is no process
 entry, but just a process definition which we take from the provided
 [[prclib]] definition library.
 <<Simulations: entry: TBP>>=
   procedure, private :: import_process_def_characteristics &
        => entry_import_process_def_characteristics
 <<Simulations: procedures>>=
   subroutine entry_import_process_def_characteristics (entry, prclib, id)
     class(entry_t), intent(inout) :: entry
     type(process_library_t), intent(in), target :: prclib
     type(string_t), intent(in) :: id
     entry%library = prclib%get_name ()
     entry%n_in = prclib%get_n_in (id)
   end subroutine entry_import_process_def_characteristics
 
 @ %def entry_import_process_def_characteristics
 @ Part of simulation-entry initialization: query the
 process for integration results.
 <<Simulations: entry: TBP>>=
   procedure, private :: import_process_results &
        => entry_import_process_results
 <<Simulations: procedures>>=
   subroutine entry_import_process_results (entry, process)
     class(entry_t), intent(inout) :: entry
     type(process_t), intent(in), target :: process
     if (process%has_integral ()) then
        entry%integral = process%get_integral ()
        entry%error = process%get_error ()
        call entry%set_sigma (entry%integral)
        entry%has_integral = .true.
     end if
   end subroutine entry_import_process_results
 
 @ %def entry_import_process_characteristics
 @ Part of simulation-entry initialization: create expression factory
 objects and store them.
 <<Simulations: entry: TBP>>=
   procedure, private :: prepare_expressions &
        => entry_prepare_expressions
 <<Simulations: procedures>>=
   subroutine entry_prepare_expressions (entry, local)
     class(entry_t), intent(inout) :: entry
     type(rt_data_t), intent(in), target :: local
     type(eval_tree_factory_t) :: expr_factory
     call expr_factory%init (local%pn%selection_lexpr)
     call entry%set_selection (expr_factory)
     call expr_factory%init (local%pn%reweight_expr)
     call entry%set_reweight (expr_factory)
     call expr_factory%init (local%pn%analysis_lexpr)
     call entry%set_analysis (expr_factory)
   end subroutine entry_prepare_expressions
 
 @ %def entry_prepare_expressions
 @ 
 \subsubsection{Extra (NLO) entries}
 Initializes the list of additional NLO entries.  The routine gets the
 information about how many entries to associate from [[region_data]].
 <<Simulations: entry: TBP>>=
   procedure :: setup_additional_entries => entry_setup_additional_entries
 <<Simulations: procedures>>=
   subroutine entry_setup_additional_entries (entry)
     class(entry_t), intent(inout), target :: entry
     type(entry_t), pointer :: current_entry
     integer :: i, n_phs
     type(evt_nlo_t), pointer :: evt
     integer :: mode
     evt => null ()
     select type (pcm => entry%instance%pcm)
     class is (pcm_instance_nlo_t)
        select type (config => pcm%config)
        type is (pcm_nlo_t)
           n_phs = config%region_data%n_phs
        end select
     end select
     select type (entry)
     type is (entry_t)
        current_entry => entry
        current_entry%first => entry
        call get_nlo_evt_ptr (current_entry, evt, mode)
        if (mode > EVT_NLO_SEPARATE_BORNLIKE) then
           allocate (evt%particle_set_nlo (n_phs + 1))
           evt%event_deps%n_phs = n_phs
           evt%qcd = entry%qcd
           do i = 1, n_phs
              allocate (current_entry%next)
              current_entry%next%first => current_entry%first
              current_entry => current_entry%next
              call entry%copy_entry (current_entry)
              current_entry%i_event = i
           end do
        else
           allocate (evt%particle_set_nlo (1))
        end if
     end select
   contains
     subroutine get_nlo_evt_ptr (entry, evt, mode)
       type(entry_t), intent(in), target :: entry
       type(evt_nlo_t), intent(out), pointer :: evt
       integer, intent(out) :: mode
       class(evt_t), pointer :: current_evt
       evt => null ()
       current_evt => entry%transform_first
       do
          select type (current_evt)
          type is (evt_nlo_t)
             evt => current_evt
             mode = evt%mode
             exit
          end select
          if (associated (current_evt%next)) then
             current_evt => current_evt%next
          else
             call msg_fatal ("evt_nlo not in list of event transforms")
          end if
       end do
     end subroutine get_nlo_evt_ptr
   end subroutine entry_setup_additional_entries
 
 @ %def entry_setup_additional_entries
 @
 <<Simulations: entry: TBP>>=
   procedure :: get_first => entry_get_first
 <<Simulations: procedures>>=
   function entry_get_first (entry) result (entry_out)
     class(entry_t), intent(in), target :: entry
     type(entry_t), pointer :: entry_out
     entry_out => null ()
     select type (entry)
     type is (entry_t)
        if (entry%is_nlo ()) then
           entry_out => entry%first
        else
           entry_out => entry
        end if
     end select
   end function entry_get_first
 
 @ %def entry_get_first
 @
 <<Simulations: entry: TBP>>=
   procedure :: get_next => entry_get_next
 <<Simulations: procedures>>=
   function entry_get_next (entry) result (next_entry)
      class(entry_t), intent(in) :: entry
      type(entry_t), pointer :: next_entry
      next_entry => null ()
      if (associated (entry%next)) then
         next_entry => entry%next
      else
         call msg_fatal ("Get next entry: No next entry")
      end if
   end function entry_get_next
 
 @ %def entry_get_next
 @
 <<Simulations: entry: TBP>>=
   procedure :: count_nlo_entries => entry_count_nlo_entries
 <<Simulations: procedures>>=
   function entry_count_nlo_entries (entry) result (n)
     class(entry_t), intent(in), target :: entry
     integer :: n
     type(entry_t), pointer :: current_entry
     n = 1
     if (.not. associated (entry%next)) then
        return
     else
        current_entry => entry%next
        do
           n = n + 1
           if (.not. associated (current_entry%next)) exit
           current_entry => current_entry%next
        end do
     end if
   end function entry_count_nlo_entries
 
 @ %def entry_count_nlo_entries
 @
 <<Simulations: entry: TBP>>=
   procedure :: reset_nlo_counter => entry_reset_nlo_counter
 <<Simulations: procedures>>=
   subroutine entry_reset_nlo_counter (entry)
     class(entry_t), intent(inout) :: entry
     class(evt_t), pointer :: evt
     evt => entry%transform_first
     do
        select type (evt)
        type is (evt_nlo_t)
           evt%i_evaluation = 0
           exit
        end select
        if (associated (evt%next)) evt => evt%next
    end do
   end subroutine entry_reset_nlo_counter
 
 @ %def entry_reset_nlo_counter
 @
 <<Simulations: entry: TBP>>=
   procedure :: determine_if_powheg_matching => entry_determine_if_powheg_matching
 <<Simulations: procedures>>=
   subroutine entry_determine_if_powheg_matching (entry)
      class(entry_t), intent(inout) :: entry
      class(evt_t), pointer :: current_transform
      if (associated (entry%transform_first)) then
         current_transform => entry%transform_first
         do
            select type (current_transform)
            type is (evt_shower_t)
               if (current_transform%contains_powheg_matching ()) &
                   entry%evt_powheg => current_transform
               exit
            end select
            if (associated (current_transform%next)) then
               current_transform => current_transform%next
            else
               exit
            end if
         end do
      end if
   end subroutine entry_determine_if_powheg_matching
 
 @ %def entry_determine_if_powheg_matching
 @
 \subsubsection{Event-transform initialization}
 Part of simulation-entry initialization: dispatch event transforms
 (decay, shower) as requested.  If a transform is not applicable or
 switched off via some variable, it will be skipped.
 
 Regarding resonances/decays: these two transforms are currently mutually
 exclusive.  Resonance insertion will not be applied if there is an
 unstable particle in the game.
 <<Simulations: entry: TBP>>=
   procedure, private :: setup_event_transforms &
        => entry_setup_event_transforms
 <<Simulations: procedures>>=
   subroutine entry_setup_event_transforms (entry, process, local)
     class(entry_t), intent(inout) :: entry
     type(process_t), intent(inout), target :: process
     type(rt_data_t), intent(in), target :: local
     class(evt_t), pointer :: evt
     type(var_list_t), pointer :: var_list
     logical :: enable_isr_handler
     logical :: enable_epa_handler
     logical :: enable_fixed_order
     logical :: enable_shower
     character(len=7) :: sample_normalization
     var_list => local%get_var_list_ptr ()
     enable_isr_handler = local%get_lval (var_str ("?isr_handler"))
     enable_epa_handler = local%get_lval (var_str ("?epa_handler"))
     if (enable_isr_handler .or. enable_epa_handler) then
        call dispatch_evt_isr_epa_handler (evt, local%var_list)
        if (associated (evt))  call entry%import_transform (evt)
     end if
     if (process%contains_unstable (local%model)) then
        call dispatch_evt_decay (evt, local%var_list)
        if (associated (evt))  call entry%import_transform (evt)
     else if (entry%resonant_subprocess_set%is_active ()) then
        call dispatch_evt_resonance (evt, local%var_list, &
             entry%resonant_subprocess_set%get_resonance_history_set (), &
             entry%resonant_subprocess_set%get_libname ())
        if (associated (evt)) then
           call entry%resonant_subprocess_set%connect_transform (evt)
           call entry%resonant_subprocess_set%set_on_shell_limit &
                (local%get_rval (var_str ("resonance_on_shell_limit")))
           call entry%resonant_subprocess_set%set_on_shell_turnoff &
                (local%get_rval (var_str ("resonance_on_shell_turnoff")))
           call entry%resonant_subprocess_set%set_background_factor &
                (local%get_rval (var_str ("resonance_background_factor")))
           call entry%import_transform (evt)
        end if
     end if
     enable_fixed_order = local%get_lval (var_str ("?fixed_order_nlo_events"))
     if (enable_fixed_order) then
        if (local%get_lval (var_str ("?unweighted"))) &
           call msg_fatal ("NLO Fixed Order events have to be generated with &
                           &?unweighted = false")
        sample_normalization = local%get_sval (var_str ("$sample_normalization"))
        if ( sample_normalization /= "sigma" .and. sample_normalization /= "auto" ) &
           call msg_fatal ('For NLO Fixed Order events only $sample_normalization = &
                           &"sigma" is supported.')
        call dispatch_evt_nlo (evt, local%get_lval (var_str ("?keep_failed_events")))
        call entry%import_transform (evt)
     end if
     enable_shower = local%get_lval (var_str ("?allow_shower")) .and. &
             (local%get_lval (var_str ("?ps_isr_active")) &
             .or. local%get_lval (var_str ("?ps_fsr_active")) &
             .or. local%get_lval (var_str ("?muli_active")) &
             .or. local%get_lval (var_str ("?mlm_matching")) &
             .or. local%get_lval (var_str ("?ckkw_matching")) &
             .or. local%get_lval (var_str ("?powheg_matching")))
     if (enable_shower) then
        call dispatch_evt_shower (evt, var_list, local%model, &
             local%fallback_model, local%os_data, local%beam_structure, &
             process)
        call entry%import_transform (evt)
     end if
     if (local%get_lval (var_str ("?hadronization_active"))) then
        call dispatch_evt_hadrons (evt, var_list, local%fallback_model)
        call entry%import_transform (evt)
     end if
   end subroutine entry_setup_event_transforms
 
 @ %def entry_setup_event_transforms
 @
 \subsubsection{Process/MCI selector}
 Compute weights.  The integral in the argument is the sum of integrals for
 all processes in the sample.  After computing the process weights, we repeat
 the normalization procedure for the process components.
 <<Simulations: entry: TBP>>=
   procedure :: init_mci_selector => entry_init_mci_selector
 <<Simulations: procedures>>=
   subroutine entry_init_mci_selector (entry, negative_weights)
     class(entry_t), intent(inout), target :: entry
     logical, intent(in), optional :: negative_weights
     type(entry_t), pointer :: current_entry
     integer :: i, j, k
     if (debug_on) call msg_debug (D_CORE, "entry_init_mci_selector")
     if (entry%has_integral) then
        select type (entry)
        type is (entry_t)
           current_entry => entry
           do j = 1, current_entry%count_nlo_entries ()
              if (j > 1) current_entry => current_entry%get_next ()
              do k = 1, size(current_entry%mci_sets%integral)
                 if (debug_on) call msg_debug (D_CORE, "current_entry%mci_sets(k)%integral", &
                      current_entry%mci_sets(k)%integral)
              end do
              call current_entry%mci_selector%init &
                   (current_entry%mci_sets%integral, negative_weights)
              do i = 1, current_entry%n_mci
                 current_entry%mci_sets(i)%weight_mci = &
                    current_entry%mci_selector%get_weight (i)
              end do
           end do
        end select
     end if
   end subroutine entry_init_mci_selector
 
 @ %def entry_init_mci_selector
 @ Select a MCI entry, using the embedded random-number generator.
 <<Simulations: entry: TBP>>=
   procedure :: select_mci => entry_select_mci
 <<Simulations: procedures>>=
   function entry_select_mci (entry) result (i_mci)
     class(entry_t), intent(inout) :: entry
     integer :: i_mci
     if (debug_on) call msg_debug2 (D_CORE, "entry_select_mci")
     i_mci = entry%process%extract_active_component_mci ()
     if (i_mci == 0) call entry%mci_selector%generate (entry%rng, i_mci)
     if (debug_on) call msg_debug2 (D_CORE, "i_mci", i_mci)
   end function entry_select_mci
 
 @ %def entry_select_mci
 @
 \subsubsection{Entries: event-wise updates}
 Record an event for this entry, i.e., increment the appropriate counters.
 <<Simulations: entry: TBP>>=
   procedure :: record => entry_record
 <<Simulations: procedures>>=
   subroutine entry_record (entry, i_mci, from_file)
     class(entry_t), intent(inout) :: entry
     integer, intent(in) :: i_mci
     logical, intent(in), optional :: from_file
     real(default) :: weight, excess
     integer :: n_dropped
     weight = entry%get_weight_prc ()
     excess = entry%get_excess_prc ()
     n_dropped = entry%get_n_dropped ()
     call entry%counter%record (weight, excess, n_dropped, from_file)
     if (i_mci > 0) then
        call entry%mci_sets(i_mci)%counter%record (weight, excess)
     end if
   end subroutine entry_record
 
 @ %def entry_record
 @ Update and restore the process core that this entry accesses, when
 parameters change.  If explicit arguments [[model]], [[qcd]], or
 [[helicity_selection]] are provided, use those.  Otherwise use the
 parameters stored in the process object.
 
 These two procedures come with a caching mechanism which guarantees
 that the current core object is saved when calling [[update_process]],
 and restored by calling [[restore_process]].  If the flag [[saved]] is
 unset, saving is skipped, and the [[restore]] procedure should not be
 called.
 <<Simulations: entry: TBP>>=
   procedure :: update_process => entry_update_process
   procedure :: restore_process => entry_restore_process
 <<Simulations: procedures>>=
   subroutine entry_update_process &
        (entry, model, qcd, helicity_selection, saved)
     class(entry_t), intent(inout) :: entry
     class(model_data_t), intent(in), optional, target :: model
     type(qcd_t), intent(in), optional :: qcd
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     logical, intent(in), optional :: saved
     type(process_t), pointer :: process
     class(prc_core_t), allocatable :: core
     integer :: i, n_terms
     class(model_data_t), pointer :: model_local
     type(qcd_t) :: qcd_local
     logical :: use_saved
     if (present (model)) then
        model_local => model
     else
        model_local => entry%model
     end if
     if (present (qcd)) then
        qcd_local = qcd
     else
        qcd_local = entry%qcd
     end if
     use_saved = .true.;  if (present (saved))  use_saved = saved
     process => entry%get_process_ptr ()
     n_terms = process%get_n_terms ()
     if (use_saved)  allocate (entry%core_safe (n_terms))
     do i = 1, n_terms
        if (process%has_matrix_element (i, is_term_index = .true.)) then
           call process%extract_core (i, core)
           if (use_saved) then
              call dispatch_core_update (core, &
                   model_local, helicity_selection, qcd_local, &
                   entry%core_safe(i)%core)
           else
              call dispatch_core_update (core, &
                   model_local, helicity_selection, qcd_local)
           end if
           call process%restore_core (i, core)
        end if
     end do
   end subroutine entry_update_process
 
   subroutine entry_restore_process (entry)
     class(entry_t), intent(inout) :: entry
     type(process_t), pointer :: process
     class(prc_core_t), allocatable :: core
     integer :: i, n_terms
     process => entry%get_process_ptr ()
     n_terms = process%get_n_terms ()
     do i = 1, n_terms
        if (process%has_matrix_element (i, is_term_index = .true.)) then
           call process%extract_core (i, core)
           call dispatch_core_restore (core, entry%core_safe(i)%core)
           call process%restore_core (i, core)
        end if
     end do
     deallocate (entry%core_safe)
   end subroutine entry_restore_process
 
 @ %def entry_update_process
 @ %def entry_restore_process
 <<Simulations: entry: TBP>>=
   procedure :: connect_qcd => entry_connect_qcd
 <<Simulations: procedures>>=
   subroutine entry_connect_qcd (entry)
     class(entry_t), intent(inout), target :: entry
     class(evt_t), pointer :: evt
     evt => entry%transform_first
     do while (associated (evt))
        select type (evt)
        type is (evt_shower_t)
           evt%qcd = entry%qcd
           if (allocated (evt%matching)) then
              evt%matching%qcd = entry%qcd
           end if
        end select
        evt => evt%next
     end do
   end subroutine entry_connect_qcd
 
 @ %def entry_connect_qcd
 @
 \subsection{Handling resonant subprocesses}
 Resonant subprocesses are required if we want to determine resonance histories
 when generating events.  The feature is optional, to be switched on by
 the user.
 
 This procedure initializes a new, separate process library that
 contains copies of the current process, restricted to the relevant
 resonance histories.  (If this library exists already, it is just
 kept.)  The histories can be extracted from the process object.
 
 The code has to match the assignments in
 [[create_resonant_subprocess_library]].  The library may already
 exist -- in that case, here it will be recovered without recompilation.
 <<Simulations: entry: TBP>>=
   procedure :: setup_resonant_subprocesses &
        => entry_setup_resonant_subprocesses
 <<Simulations: procedures>>=
   subroutine entry_setup_resonant_subprocesses (entry, global, process)
     class(entry_t), intent(inout) :: entry
     type(rt_data_t), intent(inout), target :: global
     type(process_t), intent(in), target :: process
     type(string_t) :: libname
     type(resonance_history_set_t) :: res_history_set
     type(process_library_t), pointer :: lib
     type(process_component_def_t), pointer :: process_component_def
     logical :: req_resonant, library_exist
     integer :: i_component
     libname = process%get_library_name ()
     lib => global%prclib_stack%get_library_ptr (libname)
     entry%has_resonant_subprocess_set = lib%req_resonant (process%get_id ())
     if (entry%has_resonant_subprocess_set) then
        libname = get_libname_res (process%get_id ())
        call entry%resonant_subprocess_set%init (process%get_n_components ())
        call entry%resonant_subprocess_set%create_library &
             (libname, global, library_exist)
        do i_component = 1, process%get_n_components ()
           call process%extract_resonance_history_set &
                (res_history_set, i_component = i_component)
           call entry%resonant_subprocess_set%fill_resonances &
                (res_history_set, i_component)
           if (.not. library_exist) then
              process_component_def &
                   => process%get_component_def_ptr (i_component)
              call entry%resonant_subprocess_set%add_to_library &
                   (i_component, &
                   process_component_def%get_prt_spec_in (), &
                   process_component_def%get_prt_spec_out (), &
                   global)
           end if
        end do
        call entry%resonant_subprocess_set%freeze_library (global)
     end if
   end subroutine entry_setup_resonant_subprocesses
 
 @ %def entry_setup_resonant_subprocesses
 @ Compile the resonant-subprocesses library.  The library is assumed
 to be the current library in the [[global]] object.  This is a simple wrapper.
 <<Simulations: entry: TBP>>=
   procedure :: compile_resonant_subprocesses &
        => entry_compile_resonant_subprocesses
 <<Simulations: procedures>>=
   subroutine entry_compile_resonant_subprocesses (entry, global)
     class(entry_t), intent(inout) :: entry
     type(rt_data_t), intent(inout), target :: global
     call entry%resonant_subprocess_set%compile_library (global)
   end subroutine entry_compile_resonant_subprocesses
 
 @ %def entry_compile_resonant_subprocesses
 @ Prepare process objects for the resonant-subprocesses library.  The
 process objects are appended to the global process stack.  We
 initialize the processes, such that we can evaluate matrix elements,
 but we do not need to integrate them.
 <<Simulations: entry: TBP>>=
   procedure :: prepare_resonant_subprocesses &
        => entry_prepare_resonant_subprocesses
 <<Simulations: procedures>>=
   subroutine entry_prepare_resonant_subprocesses (entry, local, global)
     class(entry_t), intent(inout) :: entry
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), optional, target :: global
     call entry%resonant_subprocess_set%prepare_process_objects (local, global)
   end subroutine entry_prepare_resonant_subprocesses
 
 @ %def entry_prepare_resonant_subprocesses
 @ Prepare process instances.  They are linked to their corresponding process
 objects.  Both, process and instance objects, are allocated as anonymous
 targets inside the [[resonant_subprocess_set]] component.
 
 NOTE: those anonymous object are likely forgotten during finalization of the
 parent [[event_t]] (extended as [[entry_t]]) object.  This should be checked!
 The memory leak is probably harmless as long as the event object is created
 once per run, not once per event.
 <<Simulations: entry: TBP>>=
   procedure :: prepare_resonant_subprocess_instances &
        => entry_prepare_resonant_subprocess_instances
 <<Simulations: procedures>>=
   subroutine entry_prepare_resonant_subprocess_instances (entry, global)
     class(entry_t), intent(inout) :: entry
     type(rt_data_t), intent(in), target :: global
     call entry%resonant_subprocess_set%prepare_process_instances (global)
   end subroutine entry_prepare_resonant_subprocess_instances
 
 @ %def entry_prepare_resonant_subprocess_instances
 @ Display the resonant subprocesses.  This includes, upon request, the
 resonance set that defines those subprocess, and a short or long account of the
 process objects themselves.
 <<Simulations: entry: TBP>>=
   procedure :: write_resonant_subprocess_data &
        => entry_write_resonant_subprocess_data
 <<Simulations: procedures>>=
   subroutine entry_write_resonant_subprocess_data (entry, unit)
     class(entry_t), intent(in) :: entry
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     call entry%resonant_subprocess_set%write (unit)
     write (u, "(1x,A,I0)")  "Resonant subprocesses refer to &
             &process component #", 1
   end subroutine entry_write_resonant_subprocess_data
 
 @ %def entry_write_resonant_subprocess_data
 @ Display of the master process for the current event, for diagnostics.
 <<Simulations: entry: TBP>>=
   procedure :: write_process_data => entry_write_process_data
 <<Simulations: procedures>>=
   subroutine entry_write_process_data &
        (entry, unit, show_process, show_instance, verbose)
     class(entry_t), intent(in) :: entry
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_process
     logical, intent(in), optional :: show_instance
     logical, intent(in), optional :: verbose
     integer :: u, i
     logical :: s_proc, s_inst, verb
     type(process_t), pointer :: process
     type(process_instance_t), pointer :: instance
     u = given_output_unit (unit)
     s_proc = .false.;  if (present (show_process))  s_proc = show_process
     s_inst = .false.;  if (present (show_instance))  s_inst = show_instance
     verb = .false.;  if (present (verbose))  verb = verbose
     if (s_proc .or. s_inst) then
        write (u, "(1x,A,':')")  "Process data"
        if (s_proc) then
           process => entry%process
           if (associated (process)) then
              if (verb) then
                 call write_separator (u, 2)
                 call process%write (.false., u)
              else
                 call process%show (u, verbose=.false.)
              end if
           else
              write (u, "(3x,A)")  "[not associated]"
           end if
        end if
        if (s_inst) then
           instance => entry%instance
           if (associated (instance)) then
              if (verb) then
                 call instance%write (u)
              else
                 call instance%write_header (u)
              end if
           else
              write (u, "(3x,A)")  "Process instance: [not associated]"
           end if
        end if
     end if
   end subroutine entry_write_process_data
 
 @ %def entry_write_process_data
 @
 \subsection{Entries for alternative environment}
 Entries for alternate environments.  [No additional components
 anymore, so somewhat redundant.]
 <<Simulations: types>>=
   type, extends (entry_t) :: alt_entry_t
    contains
    <<Simulations: alt entry: TBP>>
   end type alt_entry_t
 
 @ %def alt_entry_t
 @ The alternative entries are there to re-evaluate the event, given
 momenta, in a different context.
 
 Therefore, we allocate a local process object and use this as the
 reference for the local process instance, when initializing the entry.
 We temporarily import the [[process]] object into an [[integration_t]]
 wrapper, to take advantage of the associated methods.  The local
 process object is built in the context of the current environment,
 here called [[global]].  Then, we initialize the process instance.
 
 The [[master_process]] object contains the integration results to which we
 refer when recalculating an event.  Therefore, we use this object instead of
 the locally built [[process]] when we extract the integration results.
 
 The locally built [[process]] object should be finalized when done.  It
 remains accessible via the [[event_t]] base object of [[entry]], which
 contains pointers to the process and instance.
 <<Simulations: alt entry: TBP>>=
   procedure :: init_alt => alt_entry_init
 <<Simulations: procedures>>=
   subroutine alt_entry_init (entry, process_id, master_process, local)
     class(alt_entry_t), intent(inout), target :: entry
     type(string_t), intent(in) :: process_id
     type(process_t), intent(in), target :: master_process
     type(rt_data_t), intent(inout), target :: local
     type(process_t), pointer :: process
     type(process_instance_t), pointer :: process_instance
     type(string_t) :: run_id
     integer :: i
 
     call msg_message ("Simulate: initializing alternate process setup ...")
 
     run_id = &
          local%var_list%get_sval (var_str ("$run_id"))
     call local%set_log (var_str ("?rebuild_phase_space"), &
          .false., is_known = .true.)
     call local%set_log (var_str ("?check_phs_file"), &
          .false., is_known = .true.)
     call local%set_log (var_str ("?rebuild_grids"), &
          .false., is_known = .true.)
 
     call entry%basic_init (local%var_list)
 
     call prepare_local_process (process, process_id, local)
     entry%process_id = process_id
     entry%run_id = run_id
 
     call entry%import_process_characteristics (process)
 
     allocate (entry%mci_sets (entry%n_mci))
     do i = 1, size (entry%mci_sets)
        call entry%mci_sets(i)%init (i, master_process)
     end do
 
     call entry%import_process_results (master_process)
     call entry%prepare_expressions (local)
 
     call prepare_process_instance (process_instance, process, local%model)
     call entry%setup_event_transforms (process, local)
 
     call entry%connect (process_instance, local%model, local%process_stack)
     call entry%setup_expressions ()
 
     entry%model => process%get_model_ptr ()
 
     call msg_message ("...  alternate process setup complete.")
 
   end subroutine alt_entry_init
 
 @ %def alt_entry_init
 @ Copy the particle set from the master entry to the alternate entry.
 This is the particle set of the hard process.
 <<Simulations: alt entry: TBP>>=
   procedure :: fill_particle_set => entry_fill_particle_set
 <<Simulations: procedures>>=
   subroutine entry_fill_particle_set (alt_entry, entry)
     class(alt_entry_t), intent(inout) :: alt_entry
     class(entry_t), intent(in), target :: entry
     type(particle_set_t) :: pset
     call entry%get_hard_particle_set (pset)
     call alt_entry%set_hard_particle_set (pset)
     call pset%final ()
   end subroutine entry_fill_particle_set
 
 @ %def particle_set_copy_prt
 @
 \subsection{The simulation object}
 Each simulation object corresponds to an event sample, identified by
 the [[sample_id]].
 
 The simulation may cover several processes simultaneously.  All
 process-specific data, including the event records, are stored in the
 [[entry]] subobjects.  The [[current]] index indicates which record
 was selected last. [[version]] is foreseen to contain a tag on the \whizard\
 event file version. It can be
 <<Simulations: public>>=
   public :: simulation_t
 <<Simulations: types>>=
   type :: simulation_t
      private
      type(rt_data_t), pointer :: local => null ()
      type(string_t) :: sample_id
      logical :: unweighted = .true.
      logical :: negative_weights = .false.
      logical :: support_resonance_history = .false.
      logical :: respect_selection = .true.
      integer :: norm_mode = NORM_UNDEFINED
      logical :: update_sqme = .false.
      logical :: update_weight = .false.
      logical :: update_event = .false.
      logical :: recover_beams = .false.
      logical :: pacify = .false.
      integer :: n_max_tries = 10000
      integer :: n_prc = 0
      integer :: n_alt = 0
      logical :: has_integral = .false.
      logical :: valid = .false.
      real(default) :: integral = 0
      real(default) :: error = 0
      integer :: version = 1
      character(32) :: md5sum_prc = ""
      character(32) :: md5sum_cfg = ""
      character(32), dimension(:), allocatable :: md5sum_alt
      type(entry_t), dimension(:), allocatable :: entry
      type(alt_entry_t), dimension(:,:), allocatable :: alt_entry
      type(selector_t) :: process_selector
      integer :: n_evt_requested = 0
      integer :: event_index_offset = 0
      logical :: event_index_set = .false.
      integer :: event_index = 0
      integer :: split_n_evt = 0
      integer :: split_n_kbytes = 0
      integer :: split_index = 0
      type(counter_t) :: counter
      class(rng_t), allocatable :: rng
      integer :: i_prc = 0
      integer :: i_mci = 0
      real(default) :: weight = 0
      real(default) :: excess = 0
      integer :: n_dropped = 0
    contains
    <<Simulations: simulation: TBP>>
   end type simulation_t
 
 @ %def simulation_t
 @ 
 \subsubsection{Output of the simulation data}
 [[write_config]] writes just the configuration.  [[write]]
 as a method of the base type [[event_t]]
 writes the current event and process instance, depending on options.
 <<Simulations: simulation: TBP>>=
   procedure :: write => simulation_write
 <<Simulations: procedures>>=
   subroutine simulation_write (object, unit, testflag)
     class(simulation_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     logical :: pacified
     integer :: u, i
     u = given_output_unit (unit)
     pacified = object%pacify;  if (present (testflag))  pacified = testflag
     call write_separator (u, 2)
     write (u, "(1x,A,A,A)")  "Event sample: '", char (object%sample_id), "'"
     write (u, "(3x,A,I0)")  "Processes    = ", object%n_prc
     if (object%n_alt > 0) then
        write (u, "(3x,A,I0)")  "Alt.wgts     = ", object%n_alt
     end if
     write (u, "(3x,A,L1)")  "Unweighted   = ", object%unweighted
     write (u, "(3x,A,A)")   "Event norm   = ", &
          char (event_normalization_string (object%norm_mode))
     write (u, "(3x,A,L1)")  "Neg. weights = ", object%negative_weights
     write (u, "(3x,A,L1)")  "Res. history = ", object%support_resonance_history
     write (u, "(3x,A,L1)")  "Respect sel. = ", object%respect_selection
     write (u, "(3x,A,L1)")  "Update sqme  = ", object%update_sqme
     write (u, "(3x,A,L1)")  "Update wgt   = ", object%update_weight
     write (u, "(3x,A,L1)")  "Update event = ", object%update_event
     write (u, "(3x,A,L1)")  "Recov. beams = ", object%recover_beams
     write (u, "(3x,A,L1)")  "Pacify       = ", object%pacify
     write (u, "(3x,A,I0)")  "Max. tries   = ", object%n_max_tries
     if (object%has_integral) then
        if (pacified) then
           write (u, "(3x,A," // FMT_15 // ")")  &
                "Integral     = ", object%integral
           write (u, "(3x,A," // FMT_15 // ")")  &
                "Error        = ", object%error
        else
           write (u, "(3x,A," // FMT_19 // ")")  &
                "Integral     = ", object%integral
           write (u, "(3x,A," // FMT_19 // ")")  &
                "Error        = ", object%error
        end if
     else
        write (u, "(3x,A)")  "Integral     = [undefined]"
     end if
     write (u, "(3x,A,L1)")  "Sim. valid   = ", object%valid
     write (u, "(3x,A,I0)")  "Ev.file ver. = ", object%version
     if (object%md5sum_prc /= "") then
        write (u, "(3x,A,A,A)")  "MD5 sum (proc)   = '", object%md5sum_prc, "'"
     end if
     if (object%md5sum_cfg /= "") then
        write (u, "(3x,A,A,A)")  "MD5 sum (config) = '", object%md5sum_cfg, "'"
     end if
     write (u, "(3x,A,I0)")  "Events requested  = ", object%n_evt_requested
     if (object%event_index_offset /= 0) then
        write (u, "(3x,A,I0)")  "Event index offset= ", object%event_index_offset
     end if
     if (object%event_index_set) then
        write (u, "(3x,A,I0)")  "Event index       = ", object%event_index
     end if
     if (object%split_n_evt > 0 .or. object%split_n_kbytes > 0) then
        write (u, "(3x,A,I0)")  "Events per file   = ", object%split_n_evt
        write (u, "(3x,A,I0)")  "KBytes per file   = ", object%split_n_kbytes
        write (u, "(3x,A,I0)")  "First file index  = ", object%split_index
     end if
     call object%counter%write (u)
     call write_separator (u)
     if (object%i_prc /= 0) then
        write (u, "(1x,A)")  "Current event:"
        write (u, "(3x,A,I0,A,A)")  "Process #", &
             object%i_prc, ": ", &
             char (object%entry(object%i_prc)%process_id)
        write (u, "(3x,A,I0)")  "MCI set #", object%i_mci
        write (u, "(3x,A," // FMT_19 // ")")  "Weight    = ", object%weight
        if (.not. vanishes (object%excess)) &
             write (u, "(3x,A," // FMT_19 // ")")  "Excess    = ", object%excess
        write (u, "(3x,A,I0)")  "Zero-weight events dropped = ", object%n_dropped
     else
        write (u, "(1x,A,I0,A,A)")  "Current event: [undefined]"
     end if
     call write_separator (u)
     if (allocated (object%rng)) then
        call object%rng%write (u)
     else
        write (u, "(3x,A)")  "Random-number generator: [undefined]"
     end if
     if (allocated (object%entry)) then
        do i = 1, size (object%entry)
           if (i == 1) then
              call write_separator (u, 2)
           else
              call write_separator (u)
           end if
           write (u, "(1x,A,I0,A)") "Process #", i, ":"
           call object%entry(i)%write_config (u, pacified)
        end do
     end if
     call write_separator (u, 2)
   end subroutine simulation_write
 
 @ %def simulation_write
 @ Write the current event record.  If an explicit index is given,
 write that event record.
 
 We implement writing to [[unit]] (event contents / debugging format)
 and writing to an [[eio]] event stream (storage). We include a [[testflag]]
 in order to suppress numerical noise in the testsuite.
 <<Simulations: simulation: TBP>>=
   generic :: write_event => write_event_unit
   procedure :: write_event_unit => simulation_write_event_unit
 <<Simulations: procedures>>=
   subroutine simulation_write_event_unit &
        (object, unit, i_prc, verbose, testflag)
     class(simulation_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer, intent(in), optional :: i_prc
     logical, intent(in), optional :: testflag
     logical :: pacified
     integer :: current
     pacified = .false.;  if (present(testflag)) pacified = testflag
     pacified = pacified .or. object%pacify
     if (present (i_prc)) then
        current = i_prc
     else
        current = object%i_prc
     end if
     if (current > 0) then
        call object%entry(current)%write (unit, verbose = verbose, &
             testflag = pacified)
     else
        call msg_fatal ("Simulation: write event: no process selected")
     end if
   end subroutine simulation_write_event_unit
 
 @ %def simulation_write_event
 @ This writes one of the alternate events, if allocated.
 <<Simulations: simulation: TBP>>=
   procedure :: write_alt_event => simulation_write_alt_event
 <<Simulations: procedures>>=
   subroutine simulation_write_alt_event (object, unit, j_alt, i_prc, &
        verbose, testflag)
     class(simulation_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: j_alt
     integer, intent(in), optional :: i_prc
     logical, intent(in), optional :: verbose
     logical, intent(in), optional :: testflag
     integer :: i, j
     if (present (j_alt)) then
        j = j_alt
     else
        j = 1
     end if
     if (present (i_prc)) then
        i = i_prc
     else
        i = object%i_prc
     end if
     if (i > 0) then
        if (j> 0 .and. j <= object%n_alt) then
           call object%alt_entry(i,j)%write (unit, verbose = verbose, &
                testflag = testflag)
        else
           call msg_fatal ("Simulation: write alternate event: out of range")
        end if
     else
        call msg_fatal ("Simulation: write alternate event: no process selected")
     end if
   end subroutine simulation_write_alt_event
 
 @ %def simulation_write_alt_event
 @ This writes the contents of the resonant subprocess set in the current event
 record.
 <<Simulations: simulation: TBP>>=
   procedure :: write_resonant_subprocess_data &
        => simulation_write_resonant_subprocess_data
 <<Simulations: procedures>>=
   subroutine simulation_write_resonant_subprocess_data (object, unit, i_prc)
     class(simulation_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: i_prc
     integer :: i
     if (present (i_prc)) then
        i = i_prc
     else
        i = object%i_prc
     end if
     call object%entry(i)%write_resonant_subprocess_data (unit)
   end subroutine simulation_write_resonant_subprocess_data
 
 @ %def simulation_write_resonant_subprocess_data
 @ The same for the master process, as an additional debugging aid.
 <<Simulations: simulation: TBP>>=
   procedure :: write_process_data &
        => simulation_write_process_data
 <<Simulations: procedures>>=
   subroutine simulation_write_process_data &
        (object, unit, i_prc, &
        show_process, show_instance, verbose)
     class(simulation_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: i_prc
     logical, intent(in), optional :: show_process
     logical, intent(in), optional :: show_instance
     logical, intent(in), optional :: verbose
     integer :: i
     if (present (i_prc)) then
        i = i_prc
     else
        i = object%i_prc
     end if
     call object%entry(i)%write_process_data &
          (unit, show_process, show_instance, verbose)
   end subroutine simulation_write_process_data
 
 @ %def simulation_write_process_data
 @ Write the actual efficiency of the simulation run.  We get the total
 number of events stored in the simulation counter and compare this
 with the total number of calls stored in the event entries.
 
 In order not to miscount samples that are partly read from file, use
 the [[generated]] counter, not the [[total]] counter.
 <<Simulations: simulation: TBP>>=
   procedure :: show_efficiency => simulation_show_efficiency
 <<Simulations: procedures>>=
   subroutine simulation_show_efficiency (simulation)
     class(simulation_t), intent(inout) :: simulation
     integer :: n_events, n_calls
     real(default) :: eff
     n_events = simulation%counter%generated
     n_calls = sum (simulation%entry%get_actual_calls_total ())
     if (n_calls > 0) then
        eff = real (n_events, kind=default) / n_calls
        write (msg_buffer, "(A,1x,F6.2,1x,A)") &
             "Events: actual unweighting efficiency =", 100 * eff, "%"
        call msg_message ()
     end if
   end subroutine simulation_show_efficiency
 
 @ %def simulation_show_efficiency
 @ Compute the checksum of the process set.  We retrieve the MD5 sums
 of all processes.  This depends only on the process definitions, while
 parameters are not considered.  The configuration checksum is
 retrieved from the MCI records in the process objects and furthermore
 includes beams, parameters, integration results, etc., so matching the
 latter should guarantee identical physics.
 <<Simulations: simulation: TBP>>=
   procedure :: compute_md5sum => simulation_compute_md5sum
 <<Simulations: procedures>>=
   subroutine simulation_compute_md5sum (simulation)
     class(simulation_t), intent(inout) :: simulation
     type(process_t), pointer :: process
     type(string_t) :: buffer
     integer :: j, i, n_mci, i_mci, n_component, i_component
     if (simulation%md5sum_prc == "") then
        buffer = ""
        do i = 1, simulation%n_prc
           if (.not. simulation%entry(i)%valid) cycle
           process => simulation%entry(i)%get_process_ptr ()
           if (associated (process)) then
              n_component = process%get_n_components ()
              do i_component = 1, n_component
                 if (process%has_matrix_element (i_component)) then
                    buffer = buffer // process%get_md5sum_prc (i_component)
                 end if
              end do
           end if
        end do
        simulation%md5sum_prc = md5sum (char (buffer))
     end if
     if (simulation%md5sum_cfg == "") then
        buffer = ""
        do i = 1, simulation%n_prc
           if (.not. simulation%entry(i)%valid) cycle
           process => simulation%entry(i)%get_process_ptr ()
           if (associated (process)) then
              n_mci = process%get_n_mci ()
              do i_mci = 1, n_mci
                 buffer = buffer // process%get_md5sum_mci (i_mci)
              end do
           end if
        end do
        simulation%md5sum_cfg = md5sum (char (buffer))
     end if
     do j = 1, simulation%n_alt
        if (simulation%md5sum_alt(j) == "") then
           buffer = ""
           do i = 1, simulation%n_prc
              process => simulation%alt_entry(i,j)%get_process_ptr ()
              if (associated (process)) then
                 buffer = buffer // process%get_md5sum_cfg ()
              end if
           end do
           simulation%md5sum_alt(j) = md5sum (char (buffer))
        end if
     end do
   end subroutine simulation_compute_md5sum
 
 @ %def simulation_compute_md5sum
 @
 \subsubsection{Simulation-object finalizer}
 <<Simulations: simulation: TBP>>=
   procedure :: final => simulation_final
 <<Simulations: procedures>>=
   subroutine simulation_final (object)
     class(simulation_t), intent(inout) :: object
     integer :: i, j
     if (allocated (object%entry)) then
        do i = 1, size (object%entry)
           call object%entry(i)%final ()
        end do
     end if
     if (allocated (object%alt_entry)) then
        do j = 1, size (object%alt_entry, 2)
           do i = 1, size (object%alt_entry, 1)
              call object%alt_entry(i,j)%final ()
           end do
        end do
     end if
     if (allocated (object%rng))  call object%rng%final ()
   end subroutine simulation_final
 
 @ %def simulation_final
 @ 
 \subsubsection{Simulation-object initialization}
 We can deduce all data from the given list of
 process IDs and the global data set.  The process objects are taken
 from the stack.  Once the individual integrals are known, we add them (and the
 errors), to get the sample integral.
 
 If there are alternative environments, we suspend initialization for
 setting up alternative process objects, then restore the master
 process and its parameters.  The generator or rescanner can then
 switch rapidly between processes.
 
 If [[integrate]] is set, we make sure that all affected processes are
 integrated before simulation.  This is necessary if we want to actually
 generate events.  If [[integrate]] is unset, we do not need the integral
 because we just rescan existing events.  In that case, we just need compiled
 matrix elements.
 
 If [[generate]] is set, we prepare for actually generating events.  Otherwise,
 we may only read and rescan events.
 <<Simulations: simulation: TBP>>=
   procedure :: init => simulation_init
 <<Simulations: procedures>>=
   subroutine simulation_init (simulation, &
        process_id, integrate, generate, local, global, alt_env)
     class(simulation_t), intent(out), target :: simulation
     type(string_t), dimension(:), intent(in) :: process_id
     logical, intent(in) :: integrate, generate
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), optional, target :: global
     type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env
     class(rng_factory_t), allocatable :: rng_factory
     integer :: next_rng_seed
     type(string_t) :: norm_string, version_string
     logical :: use_process
     integer :: i, j
     type(string_t) :: sample_suffix
   <<Simulations: simulation init: extra variables>>
     sample_suffix = ""
   <<Simulations: simulation init: extra init>>
     simulation%local => local
     simulation%sample_id = &
          local%get_sval (var_str ("$sample"))
     simulation%unweighted = &
          local%get_lval (var_str ("?unweighted"))
     simulation%negative_weights = &
          local%get_lval (var_str ("?negative_weights"))
     simulation%support_resonance_history = &
          local%get_lval (var_str ("?resonance_history"))
     simulation%respect_selection = &
          local%get_lval (var_str ("?sample_select"))
     version_string = &
          local%get_sval (var_str ("$event_file_version"))
     norm_string = &
          local%get_sval (var_str ("$sample_normalization"))
     simulation%norm_mode = &
          event_normalization_mode (norm_string, simulation%unweighted)
     simulation%pacify = &
          local%get_lval (var_str ("?sample_pacify"))
     simulation%event_index_offset = &
          local%get_ival (var_str ("event_index_offset"))
     simulation%n_max_tries = &
          local%get_ival (var_str ("sample_max_tries"))
     simulation%split_n_evt = &
          local%get_ival (var_str ("sample_split_n_evt"))
     simulation%split_n_kbytes = &
          local%get_ival (var_str ("sample_split_n_kbytes"))
     simulation%split_index = &
          local%get_ival (var_str ("sample_split_index"))
     simulation%update_sqme = &
          local%get_lval (var_str ("?update_sqme"))
     simulation%update_weight = &
          local%get_lval (var_str ("?update_weight"))
     simulation%update_event = &
          local%get_lval (var_str ("?update_event"))
     simulation%recover_beams = &
          local%get_lval (var_str ("?recover_beams"))
     simulation%counter%reproduce_xsection = &
          local%get_lval (var_str ("?check_event_weights_against_xsection"))
     use_process = &
          integrate .or. generate &
          .or. simulation%update_sqme &
          .or. simulation%update_weight &
          .or. simulation%update_event &
          .or. present (alt_env)
     select case (size (process_id))
     case (0)
        call msg_error ("Simulation: no process selected")
     case (1)
        write (msg_buffer, "(A,A,A)") &
             "Starting simulation for process '", &
             char (process_id(1)), "'"
        call msg_message ()
     case default
        write (msg_buffer, "(A,A,A)") &
             "Starting simulation for processes '", &
             char (process_id(1)), "' etc."
        call msg_message ()
     end select
     select case (char (version_string))
     case ("", "2.2.4")
        simulation%version = 2
     case ("2.2")
        simulation%version = 1
     case default
        simulation%version = 0
     end select
     if (simulation%version == 0) then
        call msg_fatal ("Event file format '" &
             // char (version_string) &
             // "' is not compatible with this version.")
     end if
     simulation%n_prc = size (process_id)
     allocate (simulation%entry (simulation%n_prc))
     if (present (alt_env)) then
        simulation%n_alt = size (alt_env)
        do i = 1, simulation%n_prc
           call simulation%entry(i)%init (process_id(i), &
                use_process, integrate, generate, &
                simulation%update_sqme, &
                simulation%support_resonance_history, &
                local, global, simulation%n_alt)
           if (signal_is_pending ())  return
        end do
        simulation%valid = any (simulation%entry%valid)
        if (.not. simulation%valid) then
           call msg_error ("Simulate: no process has a valid matrix element.")
           return
        end if
        call simulation%update_processes ()
        allocate (simulation%alt_entry (simulation%n_prc, simulation%n_alt))
        allocate (simulation%md5sum_alt (simulation%n_alt))
        simulation%md5sum_alt = ""
        do j = 1, simulation%n_alt
           do i = 1, simulation%n_prc
              call simulation%alt_entry(i,j)%init_alt (process_id(i), &
                   simulation%entry(i)%get_process_ptr (), alt_env(j))
              if (signal_is_pending ())  return
           end do
        end do
        call simulation%restore_processes ()
     else
        do i = 1, simulation%n_prc
           call simulation%entry(i)%init &
                (process_id(i), &
                use_process, integrate, generate, &
                simulation%update_sqme, &
                simulation%support_resonance_history, &
                local, global)
           call simulation%entry(i)%determine_if_powheg_matching ()
           if (signal_is_pending ())  return
           if (simulation%entry(i)%is_nlo ()) &
                call simulation%entry(i)%setup_additional_entries ()
        end do
        simulation%valid = any (simulation%entry%valid)
        if (.not. simulation%valid) then
           call msg_error ("Simulate: " &
                // "no process has a valid matrix element.")
           return
        end if
     end if
 !!! if this becomes conditional, some ref files will need update (seed change)
 !    if (generate) then
        call dispatch_rng_factory (rng_factory, local%var_list, next_rng_seed)
        call update_rng_seed_in_var_list (local%var_list, next_rng_seed)
        call rng_factory%make (simulation%rng)
      <<Simulations: simulation init: extra RNG init>>
 !    end if
     if (all (simulation%entry%has_integral)) then
        simulation%integral = sum (simulation%entry%integral)
        simulation%error = sqrt (sum (simulation%entry%error ** 2))
        simulation%has_integral = .true.
        if (integrate .and. generate) then
           do i = 1, simulation%n_prc
              if (simulation%entry(i)%integral < 0 .and. .not. &
                   simulation%negative_weights) then
                 call msg_fatal ("Integral of process '" // &
                      char (process_id (i)) // "'is negative.")
              end if
           end do
        end if
     else
        if (integrate .and. generate) &
             call msg_error ("Simulation contains undefined integrals.")
     end if
     if (simulation%integral > 0 .or. &
          (simulation%integral < 0 .and. simulation%negative_weights)) then
        simulation%valid = .true.
     else if (generate) then
        call msg_error ("Simulate: " &
             // "sum of process integrals must be positive; skipping.")
        simulation%valid = .false.
     else
        simulation%valid = .true.
     end if
     if (simulation%sample_id == "") then
        simulation%sample_id = simulation%get_default_sample_name ()
     end if
     simulation%sample_id = simulation%sample_id // sample_suffix
     if (simulation%valid)  call simulation%compute_md5sum ()
   end subroutine simulation_init
 
 @ %def simulation_init
 @ The RNG initialization depends on serial/MPI mode.
 <<Simulations: simulation init: extra variables>>=
 <<MPI: Simulations: simulation init: extra variables>>=
   integer :: rank, n_size
 <<Simulations: simulation init: extra init>>=
 <<MPI: Simulations: simulation init: extra init>>=
   call mpi_get_comm_id (n_size, rank)
   if (n_size > 1) then
      sample_suffix = var_str ("_") // str (rank)
   end if
 <<Simulations: simulation init: extra RNG init>>=
 <<MPI: Simulations: simulation init: extra RNG init>>=
   do i = 2, rank + 1
      select type (rng => simulation%rng)
      type is (rng_stream_t)
         call rng%next_substream ()
         if (i == rank) &
            call msg_message ("Simulate: Advance RNG for parallel event generation")
      class default
         call rng%write ()
         call msg_bug ("Parallel event generation: random-number generator &
                &must be 'rng_stream'.")
      end select
   end do
 @ The number of events that we want to simulate is determined by the
 settings of [[n_events]], [[luminosity]], and [[?unweighted]].  For
 weighted events, we take [[n_events]] at face value as the number of
 matrix element calls.  For unweighted events, if the process is a
 decay, [[n_events]] is the number of unweighted events.  In these
 cases, the luminosity setting is ignored.
 
 For unweighted events with a scattering process, we calculate the
 event number that corresponds to the luminosity, given the current
 value of the integral.  We then compare this with [[n_events]] and
 choose the larger number.
 <<Simulations: simulation: TBP>>=
   procedure :: compute_n_events => simulation_compute_n_events
 <<Simulations: procedures>>=
   subroutine simulation_compute_n_events (simulation, n_events)
     class(simulation_t), intent(in) :: simulation
     integer, intent(out) :: n_events
     real(default) :: lumi, x_events_lumi
     integer :: n_events_lumi
     logical :: is_scattering
     n_events = &
          simulation%local%get_ival (var_str ("n_events"))
     lumi = &
          simulation%local%get_rval (var_str ("luminosity"))
     if (simulation%unweighted) then
        is_scattering = simulation%entry(1)%n_in == 2
        if (is_scattering) then
           x_events_lumi = abs (simulation%integral * lumi)
           if (x_events_lumi < huge (n_events)) then
              n_events_lumi = nint (x_events_lumi)
           else
              call msg_message ("Simulation: luminosity too large, &
                   &limiting number of events")
              n_events_lumi = huge (n_events)
           end if
           if (n_events_lumi > n_events) then
              call msg_message ("Simulation: using n_events as computed from &
                   &luminosity value")
              n_events = n_events_lumi
           else
              write (msg_buffer, "(A,1x,I0)") &
                   "Simulation: requested number of events =", n_events
              call msg_message ()
              if (.not. vanishes (simulation%integral)) then
                 write (msg_buffer, "(A,1x,ES11.4)") &
                      "            corr. to luminosity [fb-1] = ", &
                      n_events / simulation%integral
                 call msg_message ()
              end if
           end if
        end if
     end if
   end subroutine simulation_compute_n_events
 
 @ %def simulation_compute_n_events
 @ Configuration of the OpenMP parameters, in case OpenMP is active.  We use
 the settings accessible via the local environment.
 <<Simulations: simulation: TBP>>=
   procedure :: setup_openmp => simulation_setup_openmp
 <<Simulations: procedures>>=
   subroutine simulation_setup_openmp (simulation)
     class(simulation_t), intent(inout) :: simulation
     
     call openmp_set_num_threads_verbose &
          (simulation%local%get_ival (var_str ("openmp_num_threads")), &
          simulation%local%get_lval (var_str ("?openmp_logging")))
     
   end subroutine simulation_setup_openmp
 
 @ %def simulation_setup_openmp
 @ Configuration of the event-stream array -- i.e., the setup of
 output file formats.
 <<Simulations: simulation: TBP>>=
   procedure :: prepare_event_streams => simulation_prepare_event_streams
 <<Simulations: procedures>>=
   subroutine simulation_prepare_event_streams (sim, es_array)
     class(simulation_t), intent(inout) :: sim
     type(event_stream_array_t), intent(out) :: es_array
 
     integer :: n_events
     logical :: rebuild_events, read_raw, write_raw
     integer :: checkpoint, callback
     integer :: n_fmt
     type(event_sample_data_t) :: data
     type(string_t), dimension(:), allocatable :: sample_fmt
 
     n_events = &
          sim%n_evt_requested
     rebuild_events = &
          sim%local%get_lval (var_str ("?rebuild_events"))
     read_raw = &
          sim%local%get_lval (var_str ("?read_raw")) .and. .not. rebuild_events
     write_raw = &
          sim%local%get_lval (var_str ("?write_raw"))
     checkpoint = &
          sim%local%get_ival (var_str ("checkpoint"))
     callback = &
          sim%local%get_ival (var_str ("event_callback_interval"))
     if (read_raw) then
        inquire (file = char (sim%sample_id) // ".evx", exist = read_raw)
     end if
     if (allocated (sim%local%sample_fmt)) then
        n_fmt = size (sim%local%sample_fmt)
     else
        n_fmt = 0
     end if
     data = sim%get_data ()
     data%n_evt = n_events
     data%nlo_multiplier = sim%get_n_nlo_entries (1)
     if (read_raw) then
        allocate (sample_fmt (n_fmt))
        if (n_fmt > 0)  sample_fmt = sim%local%sample_fmt
        call es_array%init (sim%sample_id, &
             sample_fmt, sim%local, &
             data = data, &
             input = var_str ("raw"), &
             allow_switch = write_raw, &
             checkpoint = checkpoint, &
             callback = callback)
     else if (write_raw) then
        allocate (sample_fmt (n_fmt + 1))
        if (n_fmt > 0)  sample_fmt(:n_fmt) = sim%local%sample_fmt
        sample_fmt(n_fmt+1) = var_str ("raw")
        call es_array%init (sim%sample_id, &
             sample_fmt, sim%local, &
             data = data, &
             checkpoint = checkpoint, &
             callback = callback)
     else if (allocated (sim%local%sample_fmt) &
          .or. checkpoint > 0 &
          .or. callback > 0) then
        allocate (sample_fmt (n_fmt))
        if (n_fmt > 0)  sample_fmt = sim%local%sample_fmt
        call es_array%init (sim%sample_id, &
             sample_fmt, sim%local, &
             data = data, &
             checkpoint = checkpoint, &
             callback = callback)
     end if
   end subroutine simulation_prepare_event_streams
 
 @ %def simulation_prepare_event_streams
 @
 <<Simulations: simulation: TBP>>=
   procedure :: get_n_nlo_entries => simulation_get_n_nlo_entries
 <<Simulations: procedures>>=
   function simulation_get_n_nlo_entries (simulation, i_prc) result (n_extra)
     class(simulation_t), intent(in) :: simulation
     integer, intent(in) :: i_prc
     integer :: n_extra
     n_extra = simulation%entry(i_prc)%count_nlo_entries ()
   end function simulation_get_n_nlo_entries
 
 @ %def simulation_get_n_nlo_entries
 @ Initialize the process selector, using the entry integrals as process
 weights.
 <<Simulations: simulation: TBP>>=
   procedure :: init_process_selector => simulation_init_process_selector
 <<Simulations: procedures>>=
   subroutine simulation_init_process_selector (simulation)
     class(simulation_t), intent(inout) :: simulation
     integer :: i
     if (simulation%has_integral) then
        call simulation%process_selector%init (simulation%entry%integral, &
             negative_weights = simulation%negative_weights)
        do i = 1, simulation%n_prc
           associate (entry => simulation%entry(i))
             if (.not. entry%valid) then
                call msg_warning ("Process '" // char (entry%process_id) // &
                     "': matrix element vanishes, no events can be generated.")
                cycle
             end if
             call entry%init_mci_selector (simulation%negative_weights)
             entry%process_weight = simulation%process_selector%get_weight (i)
           end associate
        end do
     end if
   end subroutine simulation_init_process_selector
 
 @ %def simulation_init_process_selector
 @ Select a process, using the random-number generator.
 <<Simulations: simulation: TBP>>=
   procedure :: select_prc => simulation_select_prc
 <<Simulations: procedures>>=
   function simulation_select_prc (simulation) result (i_prc)
     class(simulation_t), intent(inout) :: simulation
     integer :: i_prc
     call simulation%process_selector%generate (simulation%rng, i_prc)
   end function simulation_select_prc
 
 @ %def simulation_select_prc
 @ Select a MCI set for the selected process.
 <<Simulations: simulation: TBP>>=
   procedure :: select_mci => simulation_select_mci
 <<Simulations: procedures>>=
   function simulation_select_mci (simulation) result (i_mci)
     class(simulation_t), intent(inout) :: simulation
     integer :: i_mci
     i_mci = 0
     if (simulation%i_prc /= 0) then
        i_mci = simulation%entry(simulation%i_prc)%select_mci ()
     end if
   end function simulation_select_mci
 
 @ %def simulation_select_mci
 @ 
 \subsubsection{Generate-event loop}
 The requested number of events should be set by this, in time for the
 event-array initializers that may use this number.
 <<Simulations: simulation: TBP>>=
   procedure :: set_n_events_requested => simulation_set_n_events_requested
   procedure :: get_n_events_requested => simulation_get_n_events_requested
 <<Simulations: procedures>>=
   subroutine simulation_set_n_events_requested (simulation, n)
     class(simulation_t), intent(inout) :: simulation
     integer, intent(in) :: n
     
     simulation%n_evt_requested = n
     
   end subroutine simulation_set_n_events_requested
 
   function simulation_get_n_events_requested (simulation) result (n)
     class(simulation_t), intent(in) :: simulation
     integer :: n
     
     n = simulation%n_evt_requested
     
   end function simulation_get_n_events_requested
 
 @ %def simulation_set_n_events_requested
 @ %def simulation_get_n_events_requested
 @ Generate the number of events that has been set by
 [[simulation_set_n_events_requested]].  First select a process and a component
 set, then generate an event for that process and factorize the quantum state.
 The pair of random numbers can be used for factorization.
 
 When generating events, we drop all configurations where the event is
 marked as incomplete.  This happens if the event fails cuts.  In fact,
 such events are dropped already by the sampler if unweighting is in
 effect, so this can happen only for weighted events.  By setting a
 limit given by [[sample_max_tries]] (user parameter), we can avoid an
 endless loop.
 
 The [[begin_it]] and [[end_it]] limits are equal to 1 and the number of
 events, repspectively, in serial mode, but differ for MPI mode.
 
 TODO: When reading from file, event transforms cannot be applied because the
 process instance will not be complete. (?)
 <<Simulations: simulation: TBP>>=
   procedure :: generate => simulation_generate
 <<Simulations: procedures>>=
   subroutine simulation_generate (simulation, es_array)
     class(simulation_t), intent(inout), target :: simulation
     type(event_stream_array_t), intent(inout), optional :: es_array
 
     integer :: begin_it, end_it
     integer :: i, j, k
 
     call simulation%before_first_event (begin_it, end_it, es_array)
     do i = begin_it, end_it
        call simulation%next_event (es_array)
     end do
     call simulation%after_last_event (begin_it, end_it)
 
   end subroutine simulation_generate
 
 @ %def simulation_generate
 @ The header of the event loop: with all necessary information present in the
 [[simulation]] and [[es_array]] objects, and given a number of events [[n]] to
 generate, we prepare for actually generating/reading/writing events.
 
 The procedure returns the real iteration bounds [[begin_it]] and [[end_it]]
 for the event loop.  This is nontrivial only for MPI; in serial mode those are
 equal to 1 and to [[n_events]], respectively.
 <<Simulations: simulation: TBP>>=
   procedure :: before_first_event => simulation_before_first_event
 <<Simulations: procedures>>=
   subroutine simulation_before_first_event (simulation, begin_it, end_it, &
        es_array)
     class(simulation_t), intent(inout), target :: simulation
     integer, intent(out) :: begin_it
     integer, intent(out) :: end_it
     type(event_stream_array_t), intent(inout), optional :: es_array
     
     integer :: n_evt_requested
     logical :: has_input
     integer :: n_events_print
     logical :: is_leading_order
     logical :: is_weighted
     logical :: is_polarized
 
     n_evt_requested = simulation%n_evt_requested
     n_events_print = n_evt_requested * simulation%get_n_nlo_entries (1)
     is_leading_order = (n_events_print == n_evt_requested)
 
     has_input = .false.
     if (present (es_array)) has_input = es_array%has_input ()
     
     is_weighted = .not. simulation%entry(1)%config%unweighted
     is_polarized = simulation%entry(1)%config%factorization_mode &
          /= FM_IGNORE_HELICITY
 
     call simulation%startup_message_generate ( &
          has_input = has_input, &
          is_weighted = is_weighted, &
          is_polarized = is_polarized, &
          is_leading_order = is_leading_order, &
          n_events = n_events_print)
 
     call simulation%entry%set_n (n_evt_requested)
     if (simulation%n_alt > 0)  call simulation%alt_entry%set_n (n_evt_requested)
     call simulation%init_event_index ()
 
     begin_it = 1
     end_it = n_evt_requested
   <<Simulations: simulation generate: extra init>>
 
   end subroutine simulation_before_first_event
 
 @ %def simulation_before_first_event
 @ Keep the user informed:
 <<Simulations: simulation: TBP>>=
   procedure, private :: startup_message_generate &
        => simulation_startup_message_generate
 <<Simulations: procedures>>=
   subroutine simulation_startup_message_generate (simulation, &
      has_input, is_weighted, is_polarized, is_leading_order, n_events)
     class(simulation_t), intent(in) :: simulation
     logical, intent(in) :: has_input
     logical, intent(in) :: is_weighted
     logical, intent(in) :: is_polarized
     logical, intent(in) :: is_leading_order
     integer, intent(in) :: n_events
 
     type(string_t) :: str1, str2, str3, str4
 
     if (has_input) then
        str1 = "Events: reading"
     else
        str1 = "Events: generating"
     end if
     if (is_weighted) then
        str2 = "weighted"
     else
        str2 = "unweighted"
     end if
     if (is_polarized) then
        str3 = ", polarized"
     else
        str3 = ", unpolarized"
     end if
     str4 = ""
     if (.not. is_leading_order) str4 = " NLO"
 
     write (msg_buffer, "(A,1X,I0,1X,A,1X,A)")  char (str1), n_events, &
             char (str2) // char(str3) // char(str4), "events ..."
     call msg_message ()
 
     write (msg_buffer, "(A,1x,A)") "Events: event normalization mode", &
          char (event_normalization_string (simulation%norm_mode))
     call msg_message ()
 
   end subroutine simulation_startup_message_generate
 
 @ %def simulation_startup_message_generate
 @ 
 The body of the event loop: generate and process a single event.  
 
 Optionally transfer the current event to one of the provided event handles,
 for in and/or output streams.  This works for any stream for which the I/O
 stream type matches the event-handle type.
 <<Simulations: simulation: TBP>>=
   procedure :: next_event => simulation_next_event
 <<Simulations: procedures>>=
   subroutine simulation_next_event &
        (simulation, es_array, event_handle_out, event_handle_in)
     class(simulation_t), intent(inout) :: simulation
     type(event_stream_array_t), intent(inout), optional :: es_array
     class(event_handle_t), intent(inout), optional :: event_handle_out
     class(event_handle_t), intent(inout), optional :: event_handle_in
     
     type(entry_t), pointer :: current_entry
     logical :: generate_new
     logical :: passed
     integer :: j, k
 
     call simulation%increment_event_index ()
 
     if (present (es_array)) then
        call simulation%read_event &
             (es_array, .true., generate_new, event_handle_in)
     else
        generate_new = .true.
     end if
 
     if (generate_new) then
        simulation%i_prc = simulation%select_prc ()
        simulation%i_mci = simulation%select_mci ()
 
        associate (entry => simulation%entry(simulation%i_prc))
 
          entry%instance%i_mci = simulation%i_mci
          call entry%set_active_real_components ()
          current_entry => entry%get_first ()
 
          do k = 1, current_entry%count_nlo_entries ()
             if (k > 1) then
                current_entry => current_entry%get_next ()
                current_entry%particle_set => current_entry%first%particle_set
                current_entry%particle_set_is_valid &
                     = current_entry%first%particle_set_is_valid
             end if
             do j = 1, simulation%n_max_tries
                if (.not. current_entry%valid)  call msg_warning &
                     ("Process '" // char (current_entry%process_id) // "': " // &
                     "matrix element vanishes, no events can be generated.")
                call current_entry%generate (simulation%i_mci, i_nlo = k)
                if (signal_is_pending ()) return
                call simulation%counter%record_mean_and_variance &
                     (current_entry%weight_prc, k)
                if (current_entry%has_valid_particle_set ()) exit
             end do
          end do
          if (entry%is_nlo ()) call entry%reset_nlo_counter ()
 
          if (.not. entry%has_valid_particle_set ()) then
             write (msg_buffer, "(A,I0,A)")  "Simulation: failed to &
                  &generate valid event after ", &
                  simulation%n_max_tries, " tries (sample_max_tries)"
             call msg_fatal ()
          end if
 
          current_entry => entry%get_first ()
          do k = 1, current_entry%count_nlo_entries ()
             if (k > 1) current_entry => current_entry%get_next ()
             call current_entry%set_index (simulation%get_event_index ())
             call current_entry%evaluate_expressions ()
          end do
          if (signal_is_pending ()) return
 
          simulation%n_dropped = entry%get_n_dropped ()
          if (entry%passed_selection ()) then
             simulation%weight = entry%get_weight_ref ()
             simulation%excess = entry%get_excess_prc ()
          end if
          call simulation%counter%record &
               (simulation%weight, simulation%excess, simulation%n_dropped)
          call entry%record (simulation%i_mci)
 
        end associate
 
     else
 
        associate (entry => simulation%entry(simulation%i_prc))
 
          call simulation%set_event_index (entry%get_index ())
          call entry%accept_sqme_ref ()
          call entry%accept_weight_ref ()
          call entry%check ()
          call entry%evaluate_expressions ()
          if (signal_is_pending ()) return
 
          simulation%n_dropped = entry%get_n_dropped ()
          if (entry%passed_selection ()) then
             simulation%weight = entry%get_weight_ref ()
             simulation%excess = entry%get_excess_prc ()
          end if
          call simulation%counter%record &
               (simulation%weight, simulation%excess, simulation%n_dropped, &
               from_file=.true.)
          call entry%record (simulation%i_mci, from_file=.true.)
 
        end associate
 
     end if
 
     call simulation%calculate_alt_entries ()
     if (simulation%pacify)  call pacify (simulation)
     if (signal_is_pending ()) return
 
     if (simulation%respect_selection) then
        passed = simulation%entry(simulation%i_prc)%passed_selection ()
     else
        passed = .true.
     end if
     if (present (es_array)) then
        call simulation%write_event (es_array, passed, event_handle_out)
     end if
 
   end subroutine simulation_next_event
 
 @ %def simulation_next_event
 @ Cleanup after last event: compute and show summary information.
 <<Simulations: simulation: TBP>>=
   procedure :: after_last_event => simulation_after_last_event
 <<Simulations: procedures>>=
   subroutine simulation_after_last_event (simulation, begin_it, end_it)
     class(simulation_t), intent(inout) :: simulation
     integer, intent(in) :: begin_it, end_it
     
     call msg_message ("        ... event sample complete.")
   <<Simulations: simulation generate: extra finalize>>
 
     if (simulation%unweighted)  call simulation%show_efficiency ()
     call simulation%counter%show_excess ()
     call simulation%counter%show_dropped ()
     call simulation%counter%show_mean_and_variance ()
 
   end subroutine simulation_after_last_event
 
 @ %def simulation_after_last_event
 @
 \subsubsection{MPI additions}
 Below, we define code chunks that differ between the serial and MPI versions.
 
 Extra logging for MPI only.
 <<Simulations: simulation: TBP>>=
   procedure :: activate_extra_logging => simulation_activate_extra_logging
 <<Simulations: procedures>>=
   subroutine simulation_activate_extra_logging (simulation)
     class(simulation_t), intent(in) :: simulation
   <<Simulations: activate extra logging>>
   end subroutine simulation_activate_extra_logging
 
 <<Simulations: activate extra logging>>=
 <<MPI: Simulations: activate extra logging>>=
   logical :: mpi_logging
   integer :: rank, n_size
   call mpi_get_comm_id (n_size, rank)
   mpi_logging = &
        (simulation%local%get_sval (var_str ("$integration_method")) == "vamp2" &
        .and. n_size > 1) &
        .or. simulation%local%get_lval (var_str ("?mpi_logging"))
   call mpi_set_logging (mpi_logging)
 @ %def simulation_activate_extra_logging
 @ 
 Extra subroutine to be called before the first event:
 <<Simulations: simulation generate: extra init>>=
 <<MPI: Simulations: simulation generate: extra init>>=
   call simulation%init_event_loop_mpi (n_evt_requested, begin_it, end_it)
 @ 
 Extra subroutine to be called after the last event:
 <<Simulations: simulation generate: extra finalize>>=
 <<MPI: Simulations: simulation generate: extra finalize>>=
   call simulation%final_event_loop_mpi (begin_it, end_it)
 @ 
 For MPI event generation, the event-loop interval (1\dots n) is split up
 into intervals of [[n_workers]]. 
 <<MPI: Simulations: simulation: TBP>>=
   procedure, private :: init_event_loop_mpi => simulation_init_event_loop_mpi
 <<MPI: Simulations: procedures>>=
   subroutine simulation_init_event_loop_mpi &
        (simulation, n_events, begin_it, end_it)
     class(simulation_t), intent(inout) :: simulation
     integer, intent(in) :: n_events
     integer, intent(out) :: begin_it, end_it
 
     integer :: rank, n_workers
 
     call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
     if (n_workers < 2) then
        begin_it = 1; end_it = n_events
        return
     end if
     call MPI_COMM_RANK (MPI_COMM_WORLD, rank)
     if (rank == 0) then
        call compute_and_scatter_intervals (n_events, begin_it, end_it)
     else
        call retrieve_intervals (begin_it, end_it)
     end if
 
     !! Event index starts by 0 (before incrementing when the first event gets generated/read in).
     !! Proof: event_index_offset in [0, N], start_it in [1, N].
     simulation%event_index_offset = simulation%event_index_offset + (begin_it - 1)
     call simulation%init_event_index ()
     write (msg_buffer, "(A,I0,A,I0,A)") &
           & "MPI: generate events [", begin_it, ":", end_it, "]"
     call msg_message ()
 
   contains
   
     subroutine compute_and_scatter_intervals (n_events, begin_it, end_it)
       integer, intent(in) :: n_events
       integer, intent(out) :: begin_it, end_it
 
       integer, dimension(:), allocatable :: all_begin_it, all_end_it
       integer :: rank, n_workers, n_events_per_worker
 
       call MPI_COMM_RANK (MPI_COMM_WORLD, rank)
       call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
       allocate (all_begin_it (n_workers), source = 1)
       allocate (all_end_it (n_workers), source = n_events)
       n_events_per_worker = floor (real (n_events, default) / n_workers)
       all_begin_it = [(1 + rank * n_events_per_worker, rank = 0, n_workers - 1)]
       all_end_it = [(rank * n_events_per_worker, rank = 1, n_workers)]
       all_end_it(n_workers) = n_events
       call MPI_SCATTER (all_begin_it, 1, MPI_INTEGER, begin_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
       call MPI_SCATTER (all_end_it, 1, MPI_INTEGER, end_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
 
     end subroutine compute_and_scatter_intervals
 
     subroutine retrieve_intervals (begin_it, end_it)
       integer, intent(out) :: begin_it, end_it
 
       integer :: local_begin_it, local_end_it
 
       call MPI_SCATTER (local_begin_it, 1, MPI_INTEGER, begin_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
       call MPI_SCATTER (local_end_it, 1, MPI_INTEGER, end_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
 
     end subroutine retrieve_intervals
 
   end subroutine simulation_init_event_loop_mpi
 
 @ %def simulation_init_event_loop_mpi
 @ 
 Synchronize, reduce and collect stuff after the event loop has completed.
 <<MPI: Simulations: simulation: TBP>>=
   procedure, private :: final_event_loop_mpi => simulation_final_event_loop_mpi
 <<MPI: Simulations: procedures>>=
   subroutine simulation_final_event_loop_mpi (simulation, begin_it, end_it)
      class(simulation_t), intent(inout) :: simulation
      integer, intent(in) :: begin_it, end_it
 
      integer :: n_workers, n_events_local, n_events_global
 
      call MPI_Barrier (MPI_COMM_WORLD)
      call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
      if (n_workers < 2) return
      n_events_local = end_it - begin_it + 1
      call MPI_ALLREDUCE (n_events_local, n_events_global, 1, MPI_INTEGER, MPI_SUM,&
           & MPI_COMM_WORLD)
      write (msg_buffer, "(2(A,1X,I0))") &
           "MPI: Number of generated events locally", n_events_local, " and in world", n_events_global
      call msg_message ()
      call simulation%counter%allreduce_record ()
      
   end subroutine simulation_final_event_loop_mpi
 
 @ %def simulation_final_event_loop_mpi
 @
 \subsubsection{Alternate environments}
 Compute the event matrix element and weight for all alternative
 environments, given the current event and selected process.  We first
 copy the particle set, then temporarily update the process core with
 local parameters, recalculate everything, and restore the process
 core.
 
 The event weight is obtained by rescaling the original event weight with the
 ratio of the new and old [[sqme]] values.  (In particular, if the old
 value was zero, the weight will stay zero.)
 
 Note: this may turn out to be inefficient because we always replace
 all parameters and recalculate everything, once for each event and
 environment.  However, a more fine-grained control requires more
 code.  In any case, while we may keep multiple process cores (which
 stay constant for a simulation run), we still have to update the
 external matrix element parameters event by event.  The matrix element
 ``object'' is present only once.
 <<Simulations: simulation: TBP>>=
   procedure :: calculate_alt_entries => simulation_calculate_alt_entries
 <<Simulations: procedures>>=
   subroutine simulation_calculate_alt_entries (simulation)
     class(simulation_t), intent(inout) :: simulation
     real(default) :: factor
     real(default), dimension(:), allocatable :: sqme_alt, weight_alt
     integer :: n_alt, i, j
     i = simulation%i_prc
     n_alt = simulation%n_alt
     if (n_alt == 0)  return
     allocate (sqme_alt (n_alt), weight_alt (n_alt))
     associate (entry => simulation%entry(i))
       do j = 1, n_alt
          if (signal_is_pending ())  return
          factor = entry%get_kinematical_weight ()
          associate (alt_entry => simulation%alt_entry(i,j))
            call alt_entry%update_process (saved=.false.)
            call alt_entry%select &
                 (entry%get_i_mci (), entry%get_i_term (), entry%get_channel ())
            call alt_entry%fill_particle_set (entry)
            call alt_entry%recalculate &
                 (update_sqme = .true., &
                 recover_beams = simulation%recover_beams, &
                 weight_factor = factor)
            if (signal_is_pending ())  return
            call alt_entry%accept_sqme_prc ()
            call alt_entry%update_normalization ()
            call alt_entry%accept_weight_prc ()
            call alt_entry%check ()
            call alt_entry%set_index (simulation%get_event_index ())
            call alt_entry%evaluate_expressions ()
            if (signal_is_pending ())  return
            sqme_alt(j) = alt_entry%get_sqme_ref ()
            if (alt_entry%passed_selection ()) then
               weight_alt(j) = alt_entry%get_weight_ref ()
            end if
          end associate
       end do
       call entry%update_process (saved=.false.)
       call entry%set (sqme_alt = sqme_alt, weight_alt = weight_alt)
       call entry%check ()
       call entry%store_alt_values ()
     end associate
   end subroutine simulation_calculate_alt_entries
 
 @ %def simulation_calculate_alt_entries
 @
 These routines take care of temporary parameter redefinitions that
 we want to take effect while recalculating the matrix elements.  We
 extract the core(s) of the processes that we are simulating, apply the
 changes, and make sure that the changes are actually used.  This is
 the duty of [[dispatch_core_update]].  When done, we restore the
 original versions using [[dispatch_core_restore]].
 <<Simulations: simulation: TBP>>=
   procedure :: update_processes => simulation_update_processes
   procedure :: restore_processes => simulation_restore_processes
 <<Simulations: procedures>>=
   subroutine simulation_update_processes (simulation, &
        model, qcd, helicity_selection)
     class(simulation_t), intent(inout) :: simulation
     class(model_data_t), intent(in), optional, target :: model
     type(qcd_t), intent(in), optional :: qcd
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     integer :: i
     do i = 1, simulation%n_prc
        call simulation%entry(i)%update_process &
             (model, qcd, helicity_selection)
     end do
   end subroutine simulation_update_processes
 
   subroutine simulation_restore_processes (simulation)
     class(simulation_t), intent(inout) :: simulation
     integer :: i
     do i = 1, simulation%n_prc
        call simulation%entry(i)%restore_process ()
     end do
   end subroutine simulation_restore_processes
 
 @ %def simulation_update_processes
 @ %def simulation_restore_processes
 @
 \subsubsection{Rescan-Events Loop}
 Rescan an undefined number of events.
 
 If [[update_event]] or [[update_sqme]] is set, we have to recalculate the
 event, starting from the particle set.  If the latter is set, this includes
 the squared matrix element (i.e., the amplitude is evaluated).  Otherwise,
 only kinematics and observables derived from it are recovered.
 
 If any of the update flags is set, we will come up with separate
 [[sqme_prc]] and [[weight_prc]] values.  (The latter is only distinct
 if [[update_weight]] is set.)  Otherwise, we accept the reference values.
 <<Simulations: simulation: TBP>>=
   procedure :: rescan => simulation_rescan
 <<Simulations: procedures>>=
   subroutine simulation_rescan (simulation, n, es_array, global)
     class(simulation_t), intent(inout) :: simulation
     integer, intent(in) :: n
     type(event_stream_array_t), intent(inout) :: es_array
     type(rt_data_t), intent(inout) :: global
     type(qcd_t) :: qcd
     type(string_t) :: str1, str2, str3
     logical :: complete
     str1 = "Rescanning"
     if (simulation%entry(1)%config%unweighted) then
        str2 = "unweighted"
     else
        str2 = "weighted"
     end if
     simulation%n_evt_requested = n
     call simulation%entry%set_n (n)
     if (simulation%update_sqme .or. simulation%update_weight) then
        call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
        call simulation%update_processes &
             (global%model, qcd, global%get_helicity_selection ())
        str3 = "(process parameters updated) "
     else
        str3 = ""
     end if
     write (msg_buffer, "(A,1x,A,1x,A,A,A)")  char (str1), char (str2), &
          "events ", char (str3), "..."
     call msg_message ()
     call simulation%init_event_index ()
     do
        call simulation%increment_event_index ()
        call simulation%read_event (es_array, .false., complete)
        if (complete)  exit
        if (simulation%update_event &
             .or. simulation%update_sqme &
             .or. simulation%update_weight) then
           call simulation%recalculate ()
           if (signal_is_pending ())  return
           associate (entry => simulation%entry(simulation%i_prc))
             call entry%update_normalization ()
             if (simulation%update_event) then
                call entry%evaluate_transforms ()
             end if
             call entry%check ()
             call entry%evaluate_expressions ()
             if (signal_is_pending ())  return
             simulation%n_dropped = entry%get_n_dropped ()
             simulation%weight = entry%get_weight_prc ()
             call simulation%counter%record &
                  (simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.)
             call entry%record (simulation%i_mci, from_file=.true.)
           end associate
        else
           associate (entry => simulation%entry(simulation%i_prc))
             call entry%accept_sqme_ref ()
             call entry%accept_weight_ref ()
             call entry%check ()
             call entry%evaluate_expressions ()
             if (signal_is_pending ())  return
             simulation%n_dropped = entry%get_n_dropped ()
             simulation%weight = entry%get_weight_ref ()
             call simulation%counter%record &
                  (simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.)
             call entry%record (simulation%i_mci, from_file=.true.)
           end associate
        end if
        call simulation%calculate_alt_entries ()
        if (signal_is_pending ())  return
        call simulation%write_event (es_array)
     end do
     call simulation%counter%show_dropped ()
     if (simulation%update_sqme .or. simulation%update_weight) then
        call simulation%restore_processes ()
     end if
   end subroutine simulation_rescan
 
 @ %def simulation_rescan
 @
 \subsubsection{Event index}
 Here we handle the event index that is kept in the simulation record.  The
 event index is valid for the current sample.  When generating or reading
 events, we initialize the index with the offset that the user provides (if any)
 and increment it for each event that is generated or read from file.  The event
 index is stored in the event-entry that is current for the event.  If an
 event on file comes with its own index, that index overwrites the predefined
 one and also resets the index within the simulation record.
 
 The event index is not connected to the [[counter]] object.  The counter is
 supposed to collect statistical information.  The event index is a user-level
 object that is visible in event records and analysis expressions.
 <<Simulations: simulation: TBP>>=
   procedure :: init_event_index => simulation_init_event_index
   procedure :: increment_event_index => simulation_increment_event_index
   procedure :: set_event_index => simulation_set_event_index
   procedure :: get_event_index => simulation_get_event_index
 <<Simulations: procedures>>=
   subroutine simulation_init_event_index (simulation)
     class(simulation_t), intent(inout) :: simulation
     call simulation%set_event_index (simulation%event_index_offset)
   end subroutine simulation_init_event_index
 
   subroutine simulation_increment_event_index (simulation)
     class(simulation_t), intent(inout) :: simulation
     if (simulation%event_index_set) then
        simulation%event_index = simulation%event_index + 1
     end if
   end subroutine simulation_increment_event_index
 
   subroutine simulation_set_event_index (simulation, i)
     class(simulation_t), intent(inout) :: simulation
     integer, intent(in) :: i
     simulation%event_index = i
     simulation%event_index_set = .true.
   end subroutine simulation_set_event_index
 
   function simulation_get_event_index (simulation) result (i)
     class(simulation_t), intent(in) :: simulation
     integer :: i
     if (simulation%event_index_set) then
        i = simulation%event_index
     else
        i = 0
     end if
   end function simulation_get_event_index
 
 @ %def simulation_init_event_index
 @ %def simulation_increment_event_index
 @ %def simulation_set_event_index
 @ %def simulation_get_event_index
 @
 \subsection{Direct event access}
 If we want to retrieve event information, we should expose the currently
 selected event [[entry]] within the simulation object.  We recall that this is
 an extension of the (generic) [[event]] type.  Assuming that we will restrict
 this to read access, we return a pointer.
 <<Simulations: simulation: TBP>>=
   procedure :: get_process_index => simulation_get_process_index
   procedure :: get_event_ptr => simulation_get_event_ptr
 <<Simulations: procedures>>=
   function simulation_get_process_index (simulation) result (i_prc)
     class(simulation_t), intent(in), target :: simulation
     integer :: i_prc
     
     i_prc = simulation%i_prc
     
   end function simulation_get_process_index
     
   function simulation_get_event_ptr (simulation) result (event)
     class(simulation_t), intent(in), target :: simulation
     class(event_t), pointer :: event
     
     event => simulation%entry(simulation%i_prc)
     
   end function simulation_get_event_ptr
     
 @ %def simulation_get_process_index
 @ %def simulation_get_event_ptr
 @
 \subsection{Event Stream I/O}
 Write an event to a generic [[eio]] event stream.  The process index
 must be selected, or the current index must be available.
 <<Simulations: simulation: TBP>>=
   generic :: write_event => write_event_eio
   procedure :: write_event_eio => simulation_write_event_eio
 <<Simulations: procedures>>=
   subroutine simulation_write_event_eio (object, eio, i_prc)
     class(simulation_t), intent(in) :: object
     class(eio_t), intent(inout) :: eio
     integer, intent(in), optional :: i_prc
     logical :: increased
     integer :: current
     if (present (i_prc)) then
        current = i_prc
     else
        current = object%i_prc
     end if
     if (current > 0) then
        if (object%split_n_evt > 0 .and. object%counter%total > 1) then
           if (mod (object%counter%total, object%split_n_evt) == 1) then
              call eio%split_out ()
           end if
        else if (object%split_n_kbytes > 0) then
           call eio%update_split_count (increased)
           if (increased)  call eio%split_out ()
        end if
        call eio%output (object%entry(current)%event_t, current, pacify = object%pacify)
     else
        call msg_fatal ("Simulation: write event: no process selected")
     end if
   end subroutine simulation_write_event_eio
 
 @ %def simulation_write_event
 @
 Read an event from a generic [[eio]] event stream.  The event stream element
 must specify the process within the sample ([[i_prc]]), the MC group for this
 process ([[i_mci]]), the selected term ([[i_term]]), the selected MC
 integration [[channel]], and the particle set of the event.
 
 We may encounter EOF, which we indicate by storing 0 for the process index
 [[i_prc]].  An I/O error will be reported, and we also abort reading.
 <<Simulations: simulation: TBP>>=
   generic :: read_event => read_event_eio
   procedure :: read_event_eio => simulation_read_event_eio
 <<Simulations: procedures>>=
   subroutine simulation_read_event_eio (object, eio)
     class(simulation_t), intent(inout) :: object
     class(eio_t), intent(inout) :: eio
     integer :: iostat, current
     call eio%input_i_prc (current, iostat)
     select case (iostat)
     case (0)
        object%i_prc = current
        call eio%input_event (object%entry(current)%event_t, iostat)
     end select
     select case (iostat)
     case (:-1)
        object%i_prc = 0
        object%i_mci = 0
     case (1:)
        call msg_error ("Reading events: I/O error, aborting read")
        object%i_prc = 0
        object%i_mci = 0
     case default
        object%i_mci = object%entry(current)%get_i_mci ()
     end select
   end subroutine simulation_read_event_eio
 
 @ %def simulation_read_event
 @
 \subsection{Event Stream Array}
 Write an event using an array of event I/O streams.
 The process index must be selected, or the current index must be
 available.
 <<Simulations: simulation: TBP>>=
   generic :: write_event => write_event_es_array
   procedure :: write_event_es_array => simulation_write_event_es_array
 <<Simulations: procedures>>=
   subroutine simulation_write_event_es_array &
        (object, es_array, passed, event_handle)
     class(simulation_t), intent(in), target :: object
     class(event_stream_array_t), intent(inout) :: es_array
     logical, intent(in), optional :: passed
     class(event_handle_t), intent(inout), optional :: event_handle
     integer :: i_prc, event_index
     integer :: i
     type(entry_t), pointer :: current_entry
     i_prc = object%i_prc
     if (i_prc > 0) then
        event_index = object%counter%total
        current_entry => object%entry(i_prc)%get_first ()
        do i = 1, current_entry%count_nlo_entries ()
           if (i > 1) current_entry => current_entry%get_next ()
           call es_array%output (current_entry%event_t, i_prc, &
              event_index, &
              passed = passed, &
              pacify = object%pacify, &
              event_handle = event_handle)
        end do
     else
        call msg_fatal ("Simulation: write event: no process selected")
     end if
   end subroutine simulation_write_event_es_array
 
 @ %def simulation_write_event
 @ Read an event using an array of event I/O streams.  Reading is
 successful if there is an input stream within the array, and if a
 valid event can be read from that stream.  If there is a stream, but
 EOF is passed when reading the first item, we switch the channel to
 output and return failure but no error message, such that new events
 can be appended to that stream.
 <<Simulations: simulation: TBP>>=
   generic :: read_event => read_event_es_array
   procedure :: read_event_es_array => simulation_read_event_es_array
 <<Simulations: procedures>>=
   subroutine simulation_read_event_es_array &
        (object, es_array, enable_switch, fail, event_handle)
     class(simulation_t), intent(inout), target :: object
     class(event_stream_array_t), intent(inout), target :: es_array
     logical, intent(in) :: enable_switch
     logical, intent(out) :: fail
     class(event_handle_t), intent(inout), optional :: event_handle
     integer :: iostat, i_prc
     type(entry_t), pointer :: current_entry => null ()
     integer :: i
     if (es_array%has_input ()) then
        fail = .false.
        call es_array%input_i_prc (i_prc, iostat)
        select case (iostat)
        case (0)
           object%i_prc = i_prc
           current_entry => object%entry(i_prc)
           do i = 1, current_entry%count_nlo_entries ()
              if (i > 1) then
                 call es_array%skip_eio_entry (iostat)
                 current_entry => current_entry%get_next ()
              end if
              call current_entry%set_index (object%get_event_index ())
              call es_array%input_event &
                   (current_entry%event_t, iostat, event_handle)
           end do
        case (:-1)
           write (msg_buffer, "(A,1x,I0,1x,A)")  &
                "... event file terminates after", &
                object%counter%read, "events."
           call msg_message ()
           if (enable_switch) then
              call es_array%switch_inout ()
              write (msg_buffer, "(A,1x,I0,1x,A)")  &
                   "Generating remaining ", &
                   object%n_evt_requested - object%counter%read, "events ..."
              call msg_message ()
           end if
           fail = .true.
           return
        end select
        select case (iostat)
        case (0)
           object%i_mci = object%entry(i_prc)%get_i_mci ()
        case default
           write (msg_buffer, "(A,1x,I0,1x,A)")  &
                "Reading events: I/O error, aborting read after", &
                object%counter%read, "events."
           call msg_error ()
           object%i_prc = 0
           object%i_mci = 0
           fail = .true.
        end select
     else
        fail = .true.
     end if
   end subroutine simulation_read_event_es_array
 
 @ %def simulation_read_event
 @
 \subsection{Recover event}
 Recalculate the process instance contents, given an event with known particle
 set.  The indices for MC, term, and channel must be already set.  The
 [[recalculate]] method of the selected entry will import the result
 into [[sqme_prc]] and [[weight_prc]].
 
 If [[recover_phs]] is set (and false), do not attempt any phase-space
 calculation.  Useful if we need only matrix elements (esp. testing); this flag
 is not stored in the simulation record.
 <<Simulations: simulation: TBP>>=
   procedure :: recalculate => simulation_recalculate
 <<Simulations: procedures>>=
   subroutine simulation_recalculate (simulation, recover_phs)
     class(simulation_t), intent(inout) :: simulation
     logical, intent(in), optional :: recover_phs
     integer :: i_prc
     i_prc = simulation%i_prc
     associate (entry => simulation%entry(i_prc))
       if (simulation%update_weight) then
          call entry%recalculate &
               (update_sqme = simulation%update_sqme, &
               recover_beams = simulation%recover_beams, &
               recover_phs = recover_phs, &
               weight_factor = entry%get_kinematical_weight ())
       else
          call entry%recalculate &
               (update_sqme = simulation%update_sqme, &
               recover_beams = simulation%recover_beams, &
               recover_phs = recover_phs)
       end if
     end associate
   end subroutine simulation_recalculate
 
 @ %def simulation_recalculate
 @
 \subsection{Extract contents of the simulation object}
 Return the MD5 sum that summarizes configuration and integration
 (but not the event file).  Used for initializing the event streams.
 <<Simulations: simulation: TBP>>=
   procedure :: get_md5sum_prc => simulation_get_md5sum_prc
   procedure :: get_md5sum_cfg => simulation_get_md5sum_cfg
   procedure :: get_md5sum_alt => simulation_get_md5sum_alt
 <<Simulations: procedures>>=
   function simulation_get_md5sum_prc (simulation) result (md5sum)
     class(simulation_t), intent(in) :: simulation
     character(32) :: md5sum
     md5sum = simulation%md5sum_prc
   end function simulation_get_md5sum_prc
 
   function simulation_get_md5sum_cfg (simulation) result (md5sum)
     class(simulation_t), intent(in) :: simulation
     character(32) :: md5sum
     md5sum = simulation%md5sum_cfg
   end function simulation_get_md5sum_cfg
 
   function simulation_get_md5sum_alt (simulation, i) result (md5sum)
     class(simulation_t), intent(in) :: simulation
     integer, intent(in) :: i
     character(32) :: md5sum
     md5sum = simulation%md5sum_alt(i)
   end function simulation_get_md5sum_alt
 
 @ %def simulation_get_md5sum_prc
 @ %def simulation_get_md5sum_cfg
 @
 Return data that may be useful for writing event files.
 
 Usually we can refer to a previously integrated process, for which we
 can fetch a process pointer.  Occasionally, we do not have this because
 we are just rescanning an externally generated file without
 calculation.  For that situation, we generate our local beam data object
 using the current enviroment, or, in simple cases, just fetch the
 necessary data from the process definition and environment.
 <<Simulations: simulation: TBP>>=
   procedure :: get_data => simulation_get_data
 <<Simulations: procedures>>=
   function simulation_get_data (simulation, alt) result (sdata)
     class(simulation_t), intent(in) :: simulation
     logical, intent(in), optional :: alt
     type(event_sample_data_t) :: sdata
     type(process_t), pointer :: process
     type(beam_data_t), pointer :: beam_data
     type(beam_structure_t), pointer :: beam_structure
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: n, i
     logical :: enable_alt, construct_beam_data
     real(default) :: sqrts
     class(model_data_t), pointer :: model
     logical :: decay_rest_frame
     type(string_t) :: process_id
     enable_alt = .true.;  if (present (alt))  enable_alt = alt
     if (debug_on) call msg_debug (D_CORE, "simulation_get_data")
     if (debug_on) call msg_debug (D_CORE, "alternative setup", enable_alt)
     if (enable_alt) then
        call sdata%init (simulation%n_prc, simulation%n_alt)
        do i = 1, simulation%n_alt
           sdata%md5sum_alt(i) = simulation%get_md5sum_alt (i)
        end do
     else
        call sdata%init (simulation%n_prc)
     end if
     sdata%unweighted = simulation%unweighted
     sdata%negative_weights = simulation%negative_weights
     sdata%norm_mode = simulation%norm_mode
     process => simulation%entry(1)%get_process_ptr ()
     if (associated (process)) then
        beam_data => process%get_beam_data_ptr ()
        construct_beam_data = .false.
     else
        n = simulation%entry(1)%n_in
        sqrts = simulation%local%get_sqrts ()
        beam_structure => simulation%local%beam_structure
        call beam_structure%check_against_n_in (n, construct_beam_data)
        if (construct_beam_data) then
           allocate (beam_data)
           model => simulation%local%model
           decay_rest_frame = &
                simulation%local%get_lval (var_str ("?decay_rest_frame"))
           call beam_data%init_structure (beam_structure, &
                sqrts, model, decay_rest_frame)
        else
           beam_data => null ()
        end if
     end if
     if (associated (beam_data)) then
        n = beam_data%get_n_in ()
        sdata%n_beam = n
        allocate (flv (n))
        flv = beam_data%get_flavor ()
        sdata%pdg_beam(:n) = flv%get_pdg ()
        sdata%energy_beam(:n) = beam_data%get_energy ()
        if (construct_beam_data)  deallocate (beam_data)
     else
        n = simulation%entry(1)%n_in
        sdata%n_beam = n
        process_id = simulation%entry(1)%process_id
        call simulation%local%prclib%get_pdg_in_1 &
             (process_id, sdata%pdg_beam(:n))
        sdata%energy_beam(:n) = sqrts / n
     end if
     do i = 1, simulation%n_prc
        if (.not. simulation%entry(i)%valid) cycle
        process => simulation%entry(i)%get_process_ptr ()
        if (associated (process)) then
           sdata%proc_num_id(i) = process%get_num_id ()
        else
           process_id = simulation%entry(i)%process_id
           sdata%proc_num_id(i) = simulation%local%prclib%get_num_id (process_id)
        end if
        if (sdata%proc_num_id(i) == 0)  sdata%proc_num_id(i) = i
        if (simulation%entry(i)%has_integral) then
           sdata%cross_section(i) = simulation%entry(i)%integral
           sdata%error(i) = simulation%entry(i)%error
        end if
     end do
     sdata%total_cross_section = sum (sdata%cross_section)
     sdata%md5sum_prc = simulation%get_md5sum_prc ()
     sdata%md5sum_cfg = simulation%get_md5sum_cfg ()
     if (simulation%split_n_evt > 0 .or. simulation%split_n_kbytes > 0) then
        sdata%split_n_evt = simulation%split_n_evt
        sdata%split_n_kbytes = simulation%split_n_kbytes
        sdata%split_index = simulation%split_index
     end if
   end function simulation_get_data
 
 @ %def simulation_get_data
 @ Return a default name for the current event sample.  This is the
 process ID of the first process.
 <<Simulations: simulation: TBP>>=
   procedure :: get_default_sample_name => simulation_get_default_sample_name
 <<Simulations: procedures>>=
   function simulation_get_default_sample_name (simulation) result (sample)
     class(simulation_t), intent(in) :: simulation
     type(string_t) :: sample
     type(process_t), pointer :: process
     sample = "whizard"
     if (simulation%n_prc > 0) then
        process => simulation%entry(1)%get_process_ptr ()
        if (associated (process)) then
           sample = process%get_id ()
        end if
     end if
   end function simulation_get_default_sample_name
 
 @ %def simulation_get_default_sample_name
 @
 <<Simulations: simulation: TBP>>=
   procedure :: is_valid => simulation_is_valid
 <<Simulations: procedures>>=
   function simulation_is_valid (simulation) result (valid)
     class(simulation_t), intent(inout) :: simulation
     logical :: valid
     valid = simulation%valid
   end function simulation_is_valid
 
 @ %def simulation_is_valid
 @
 Return the hard-interaction particle set for event entry [[i_prc]].
 <<Simulations: simulation: TBP>>=
   procedure :: get_hard_particle_set => simulation_get_hard_particle_set
 <<Simulations: procedures>>=
   function simulation_get_hard_particle_set (simulation, i_prc) result (pset)
     class(simulation_t), intent(in) :: simulation
     integer, intent(in) :: i_prc
     type(particle_set_t) :: pset
     call simulation%entry(i_prc)%get_hard_particle_set (pset)
   end function simulation_get_hard_particle_set
 
 @ %def simulation_get_hard_particle_set
 @
 \subsection{Auxiliary}
 Call pacify: eliminate numerical noise.
 <<Simulations: public>>=
   public :: pacify
 <<Simulations: interfaces>>=
   interface pacify
      module procedure pacify_simulation
   end interface
 <<Simulations: procedures>>=
   subroutine pacify_simulation (simulation)
     class(simulation_t), intent(inout) :: simulation
     integer :: i, j
     i = simulation%i_prc
     if (i > 0) then
        call pacify (simulation%entry(i))
        do j = 1, simulation%n_alt
           call pacify (simulation%alt_entry(i,j))
        end do
     end if
   end subroutine pacify_simulation
 
 @ %def pacify_simulation
 @ Manually evaluate expressions for the currently selected process.
 This is used only in the unit tests.
 <<Simulations: simulation: TBP>>=
   procedure :: evaluate_expressions => simulation_evaluate_expressions
 <<Simulations: procedures>>=
   subroutine simulation_evaluate_expressions (simulation)
     class(simulation_t), intent(inout) :: simulation
     call simulation%entry(simulation%i_prc)%evaluate_expressions ()
   end subroutine simulation_evaluate_expressions
 
 @ %def simulation_evaluate_expressions
 @ Manually evaluate event transforms for the currently selected
 process.  This is used only in the unit tests.
 <<Simulations: simulation: TBP>>=
   procedure :: evaluate_transforms => simulation_evaluate_transforms
 <<Simulations: procedures>>=
   subroutine simulation_evaluate_transforms (simulation)
     class(simulation_t), intent(inout) :: simulation
     associate (entry => simulation%entry(simulation%i_prc))
       call entry%evaluate_transforms ()
     end associate
   end subroutine simulation_evaluate_transforms
 
 @ %def simulation_evaluate_transforms
 @
 \subsection{Unit tests}
 Test module, followed by the stand-alone unit-test procedures.
 <<[[simulations_ut.f90]]>>=
 <<File header>>
 
 module simulations_ut
   use unit_tests
   use simulations_uti
 
 <<Standard module head>>
 
 <<Simulations: public test>>
 
 contains
 
 <<Simulations: test driver>>
 
 end module simulations_ut
 @ %def simulations_ut
 @
 <<[[simulations_uti.f90]]>>=
 <<File header>>
 
 module simulations_uti
 
   <<Use kinds>>
     use kinds, only: i64
   <<Use strings>>
     use io_units
     use format_defs, only: FMT_10, FMT_12
     use ifiles
     use lexers
     use parser
     use lorentz
     use flavors
     use interactions, only: reset_interaction_counter
     use process_libraries, only: process_library_t
     use prclib_stacks
     use phs_forests
     use event_base, only: generic_event_t
     use event_base, only: event_callback_t
     use particles, only: particle_set_t
     use eio_data
     use eio_base
     use eio_direct, only: eio_direct_t
     use eio_raw
     use eio_ascii
     use eio_dump
     use eio_callback
     use eval_trees
     use model_data, only: model_data_t
     use models
     use rt_data
     use event_streams
     use decays_ut, only: prepare_testbed
     use process, only: process_t
     use process_stacks, only: process_entry_t
     use process_configurations_ut, only: prepare_test_library
     use compilations, only: compile_library
     use integrations, only: integrate_process
 
     use simulations
 
     use restricted_subprocesses_uti, only: prepare_resonance_test_library
 
 <<Standard module head>>
 
 <<Simulations: test declarations>>
 
 <<Simulations: test auxiliary types>>
 
 contains
 
 <<Simulations: tests>>
 
 <<Simulations: test auxiliary>>
 
 end module simulations_uti
 
 @ %def simulations_uti
 @ API: driver for the unit tests below.
 <<Simulations: public test>>=
   public :: simulations_test
 <<Simulations: test driver>>=
   subroutine simulations_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Simulations: execute tests>>
   end subroutine simulations_test
 
 @ %def simulations_test
 @
 \subsubsection{Initialization}
 Initialize a [[simulation_t]] object, including the embedded event records.
 <<Simulations: execute tests>>=
   call test (simulations_1, "simulations_1", &
        "initialization", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_1
 <<Simulations: tests>>=
   subroutine simulations_1 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, procname2
     type(rt_data_t), target :: global
     type(simulation_t), target :: simulation
 
     write (u, "(A)")  "* Test output: simulations_1"
     write (u, "(A)")  "*   Purpose: initialize simulation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize processes"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_1a"
     procname1 = "simulation_1p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("simulations1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     procname2 = "sim_extra"
 
     call prepare_test_library (global, libname, 1, [procname2])
     call compile_library (libname, global)
     call global%set_string (var_str ("$run_id"), &
          var_str ("simulations2"), is_known = .true.)
 
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call global%set_string (var_str ("$sample"), &
          var_str ("sim1"), is_known = .true.)
     call integrate_process (procname2, global, local_stack=.true.)
 
     call simulation%init ([procname1, procname2], .false., .true., global)
     call simulation%init_process_selector ()
     call simulation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write the event record for the first process"
     write (u, "(A)")
 
     call simulation%write_event (u, i_prc = 1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_1"
 
   end subroutine simulations_1
 
 @ %def simulations_1
 @
 \subsubsection{Weighted events}
 Generate events for a single process.
 <<Simulations: execute tests>>=
   call test (simulations_2, "simulations_2", &
        "weighted events", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_2
 <<Simulations: tests>>=
   subroutine simulations_2 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1
     type(rt_data_t), target :: global
     type(simulation_t), target :: simulation
     type(event_sample_data_t) :: data
 
     write (u, "(A)")  "* Test output: simulations_2"
     write (u, "(A)")  "*   Purpose: generate events for a single process"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize processes"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_2a"
     procname1 = "simulation_2p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("simulations1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     data = simulation%get_data ()
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate three events"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (3)
     call simulation%generate ()
     call simulation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write the event record for the last event"
     write (u, "(A)")
 
     call simulation%write_event (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_2"
 
   end subroutine simulations_2
 
 @ %def simulations_2
 @
 \subsubsection{Unweighted events}
 Generate events for a single process.
 <<Simulations: execute tests>>=
   call test (simulations_3, "simulations_3", &
        "unweighted events", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_3
 <<Simulations: tests>>=
   subroutine simulations_3 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1
     type(rt_data_t), target :: global
     type(simulation_t), target :: simulation
     type(event_sample_data_t) :: data
 
     write (u, "(A)")  "* Test output: simulations_3"
     write (u, "(A)")  "*   Purpose: generate unweighted events &
          &for a single process"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize processes"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_3a"
     procname1 = "simulation_3p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("simulations1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     data = simulation%get_data ()
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate three events"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (3)
     call simulation%generate ()
     call simulation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write the event record for the last event"
     write (u, "(A)")
 
     call simulation%write_event (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_3"
 
   end subroutine simulations_3
 
 @ %def simulations_3
 @
 \subsubsection{Simulating process with structure functions}
 Generate events for a single process.
 <<Simulations: execute tests>>=
   call test (simulations_4, "simulations_4", &
        "process with structure functions", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_4
 <<Simulations: tests>>=
   subroutine simulations_4 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1
     type(rt_data_t), target :: global
     type(flavor_t) :: flv
     type(string_t) :: name
     type(simulation_t), target :: simulation
     type(event_sample_data_t) :: data
 
     write (u, "(A)")  "* Test output: simulations_4"
     write (u, "(A)")  "*   Purpose: generate events for a single process &
          &with structure functions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize processes"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_4a"
     procname1 = "simulation_4p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .true., is_known = .true.)
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%model_set_real (var_str ("ms"), &
          0._default)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call reset_interaction_counter ()
 
     call flv%init (25, global%model)
     name = flv%get_name ()
 
     call global%beam_structure%init_sf ([name, name], [1])
     call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
 
     write (u, "(A)")  "* Integrate"
     write (u, "(A)")
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     call global%set_string (var_str ("$sample"), &
          var_str ("simulations4"), is_known = .true.)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     data = simulation%get_data ()
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate three events"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (3)
     call simulation%generate ()
     call simulation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write the event record for the last event"
     write (u, "(A)")
 
     call simulation%write_event (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_4"
 
   end subroutine simulations_4
 
 @ %def simulations_4
 @
 \subsubsection{Event I/O}
 Generate event for a test process, write to file and reread.
 <<Simulations: execute tests>>=
   call test (simulations_5, "simulations_5", &
        "raw event I/O", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_5
 <<Simulations: tests>>=
   subroutine simulations_5 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, sample
     type(rt_data_t), target :: global
     class(eio_t), allocatable :: eio
     type(simulation_t), allocatable, target :: simulation
 
     write (u, "(A)")  "* Test output: simulations_5"
     write (u, "(A)")  "*   Purpose: generate events for a single process"
     write (u, "(A)")  "*            write to file and reread"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize processes"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_5a"
     procname1 = "simulation_5p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("simulations5"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     sample = "simulations5"
     call global%set_string (var_str ("$sample"), &
          sample, is_known = .true.)
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     write (u, "(A)")  "* Initialize raw event file"
     write (u, "(A)")
 
     allocate (eio_raw_t :: eio)
     call eio%init_out (sample)
 
     write (u, "(A)")  "* Generate an event"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (1)
     call simulation%generate ()
     call simulation%write_event (u)
     call simulation%write_event (eio)
 
     call eio%final ()
     deallocate (eio)
     call simulation%final ()
     deallocate (simulation)
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-read the event from file"
     write (u, "(A)")
 
     call global%set_log (var_str ("?update_sqme"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?update_weight"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
     allocate (eio_raw_t :: eio)
     call eio%init_in (sample)
 
     call simulation%read_event (eio)
     call simulation%write_event (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recalculate process instance"
     write (u, "(A)")
 
     call simulation%recalculate ()
     call simulation%evaluate_expressions ()
     call simulation%write_event (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call eio%final ()
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_5"
 
   end subroutine simulations_5
 
 @ %def simulations_5
 @
 \subsubsection{Event I/O}
 Generate event for a real process with structure functions, write to file and
 reread.
 <<Simulations: execute tests>>=
   call test (simulations_6, "simulations_6", &
        "raw event I/O with structure functions", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_6
 <<Simulations: tests>>=
   subroutine simulations_6 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, sample
     type(rt_data_t), target :: global
     class(eio_t), allocatable :: eio
     type(simulation_t), allocatable, target :: simulation
     type(flavor_t) :: flv
     type(string_t) :: name
 
     write (u, "(A)")  "* Test output: simulations_6"
     write (u, "(A)")  "*   Purpose: generate events for a single process"
     write (u, "(A)")  "*            write to file and reread"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and integrate"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_6"
     procname1 = "simulation_6p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .true., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%model_set_real (var_str ("ms"), &
          0._default)
 
     call flv%init (25, global%model)
     name = flv%get_name ()
 
     call global%beam_structure%init_sf ([name, name], [1])
     call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     sample = "simulations6"
     call global%set_string (var_str ("$sample"), &
          sample, is_known = .true.)
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     write (u, "(A)")  "* Initialize raw event file"
     write (u, "(A)")
 
     allocate (eio_raw_t :: eio)
     call eio%init_out (sample)
 
     write (u, "(A)")  "* Generate an event"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (1)
     call simulation%generate ()
     call pacify (simulation)
     call simulation%write_event (u, verbose = .true., testflag = .true.)
     call simulation%write_event (eio)
 
     call eio%final ()
     deallocate (eio)
     call simulation%final ()
     deallocate (simulation)
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-read the event from file"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call global%set_log (var_str ("?update_sqme"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?update_weight"), &
          .true., is_known = .true.)
 
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
     allocate (eio_raw_t :: eio)
     call eio%init_in (sample)
 
     call simulation%read_event (eio)
     call simulation%write_event (u, verbose = .true., testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recalculate process instance"
     write (u, "(A)")
 
     call simulation%recalculate ()
     call simulation%evaluate_expressions ()
     call simulation%write_event (u, verbose = .true., testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call eio%final ()
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_6"
 
   end subroutine simulations_6
 
 @ %def simulations_6
 @
 \subsubsection{Automatic Event I/O}
 Generate events with raw-format event file as cache: generate, reread,
 append.
 <<Simulations: execute tests>>=
   call test (simulations_7, "simulations_7", &
        "automatic raw event I/O", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_7
 <<Simulations: tests>>=
   subroutine simulations_7 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, sample
     type(rt_data_t), target :: global
     type(string_t), dimension(0) :: empty_string_array
     type(event_sample_data_t) :: data
     type(event_stream_array_t) :: es_array
     type(simulation_t), allocatable, target :: simulation
     type(flavor_t) :: flv
     type(string_t) :: name
 
     write (u, "(A)")  "* Test output: simulations_7"
     write (u, "(A)")  "*   Purpose: generate events for a single process"
     write (u, "(A)")  "*            write to file and reread"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and integrate"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_7"
     procname1 = "simulation_7p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .true., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%model_set_real (var_str ("ms"), &
          0._default)
 
     call flv%init (25, global%model)
     name = flv%get_name ()
 
     call global%beam_structure%init_sf ([name, name], [1])
     call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     sample = "simulations7"
     call global%set_string (var_str ("$sample"), &
          sample, is_known = .true.)
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     write (u, "(A)")  "* Initialize raw event file"
     write (u, "(A)")
 
     data%md5sum_prc = simulation%get_md5sum_prc ()
     data%md5sum_cfg = simulation%get_md5sum_cfg ()
     call es_array%init (sample, [var_str ("raw")], global, data)
 
     write (u, "(A)")  "* Generate an event"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (1)
     call simulation%generate (es_array)
 
     call es_array%final ()
     call simulation%final ()
     deallocate (simulation)
 
     write (u, "(A)")  "* Re-read the event from file and generate another one"
     write (u, "(A)")
 
     call global%set_log (&
          var_str ("?rebuild_events"), .false., is_known = .true.)
 
     call reset_interaction_counter ()
 
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     data%md5sum_prc = simulation%get_md5sum_prc ()
     data%md5sum_cfg = simulation%get_md5sum_cfg ()
     call es_array%init (sample, empty_string_array, global, data, &
          input = var_str ("raw"))
 
     call simulation%set_n_events_requested (2)
     call simulation%generate (es_array)
 
     call pacify (simulation)
     call simulation%write_event (u, verbose = .true.)
 
     call es_array%final ()
     call simulation%final ()
     deallocate (simulation)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-read both events from file"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     data%md5sum_prc = simulation%get_md5sum_prc ()
     data%md5sum_cfg = simulation%get_md5sum_cfg ()
     call es_array%init (sample, empty_string_array, global, data, &
          input = var_str ("raw"))
 
     call simulation%set_n_events_requested (2)
     call simulation%generate (es_array)
 
     call pacify (simulation)
     call simulation%write_event (u, verbose = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call es_array%final ()
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_7"
 
   end subroutine simulations_7
 
 @ %def simulations_7
 @
 \subsubsection{Rescanning Events}
 Generate events and rescan the resulting raw event file.
 <<Simulations: execute tests>>=
   call test (simulations_8, "simulations_8", &
        "rescan raw event file", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_8
 <<Simulations: tests>>=
   subroutine simulations_8 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, sample
     type(rt_data_t), target :: global
     type(string_t), dimension(0) :: empty_string_array
     type(event_sample_data_t) :: data
     type(event_stream_array_t) :: es_array
     type(simulation_t), allocatable, target :: simulation
     type(flavor_t) :: flv
     type(string_t) :: name
 
     write (u, "(A)")  "* Test output: simulations_8"
     write (u, "(A)")  "*   Purpose: generate events for a single process"
     write (u, "(A)")  "*            write to file and rescan"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and integrate"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_8"
     procname1 = "simulation_8p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .true., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%model_set_real (var_str ("ms"), &
          0._default)
 
     call flv%init (25, global%model)
     name = flv%get_name ()
 
     call global%beam_structure%init_sf ([name, name], [1])
     call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     sample = "simulations8"
     call global%set_string (var_str ("$sample"), &
          sample, is_known = .true.)
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     write (u, "(A)")  "* Initialize raw event file"
     write (u, "(A)")
 
     data%md5sum_prc = simulation%get_md5sum_prc ()
     data%md5sum_cfg = simulation%get_md5sum_cfg ()
     write (u, "(1x,A,A,A)")  "MD5 sum (proc)   = '", data%md5sum_prc, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (config) = '", data%md5sum_cfg, "'"
     call es_array%init (sample, [var_str ("raw")], global, &
          data)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate an event"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (1)
     call simulation%generate (es_array)
 
     call pacify (simulation)
     call simulation%write_event (u, verbose = .true., testflag = .true.)
 
     call es_array%final ()
     call simulation%final ()
     deallocate (simulation)
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-read the event from file"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     allocate (simulation)
     call simulation%init ([procname1], .false., .false., global)
     call simulation%init_process_selector ()
 
     data%md5sum_prc = simulation%get_md5sum_prc ()
     data%md5sum_cfg = ""
     write (u, "(1x,A,A,A)")  "MD5 sum (proc)   = '", data%md5sum_prc, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (config) = '", data%md5sum_cfg, "'"
     call es_array%init (sample, empty_string_array, global, data, &
          input = var_str ("raw"), input_sample = sample, allow_switch = .false.)
 
     call simulation%rescan (1, es_array, global = global)
 
     write (u, "(A)")
 
     call pacify (simulation)
     call simulation%write_event (u, verbose = .true., testflag = .true.)
 
     call es_array%final ()
     call simulation%final ()
     deallocate (simulation)
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-read again and recalculate"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call global%set_log (var_str ("?update_sqme"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?update_event"), &
          .true., is_known = .true.)
 
     allocate (simulation)
     call simulation%init ([procname1], .false., .false., global)
     call simulation%init_process_selector ()
 
     data%md5sum_prc = simulation%get_md5sum_prc ()
     data%md5sum_cfg = ""
     write (u, "(1x,A,A,A)")  "MD5 sum (proc)   = '", data%md5sum_prc, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (config) = '", data%md5sum_cfg, "'"
     call es_array%init (sample, empty_string_array, global, data, &
          input = var_str ("raw"), input_sample = sample, allow_switch = .false.)
 
     call simulation%rescan (1, es_array, global = global)
 
     write (u, "(A)")
 
     call pacify (simulation)
     call simulation%write_event (u, verbose = .true., testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call es_array%final ()
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_8"
 
   end subroutine simulations_8
 
 @ %def simulations_8
 @
 \subsubsection{Rescanning Check}
 Generate events and rescan with process mismatch.
 <<Simulations: execute tests>>=
   call test (simulations_9, "simulations_9", &
        "rescan mismatch", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_9
 <<Simulations: tests>>=
   subroutine simulations_9 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, sample
     type(rt_data_t), target :: global
     type(string_t), dimension(0) :: empty_string_array
     type(event_sample_data_t) :: data
     type(event_stream_array_t) :: es_array
     type(simulation_t), allocatable, target :: simulation
     type(flavor_t) :: flv
     type(string_t) :: name
     logical :: error
 
     write (u, "(A)")  "* Test output: simulations_9"
     write (u, "(A)")  "*   Purpose: generate events for a single process"
     write (u, "(A)")  "*            write to file and rescan"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and integrate"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_9"
     procname1 = "simulation_9p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("vamp"), is_known = .true.)
     call global%set_log (var_str ("?use_vamp_equivalences"),&
          .true., is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%model_set_real (var_str ("ms"), &
          0._default)
 
     call flv%init (25, global%model)
     name = flv%get_name ()
 
     call global%beam_structure%init_sf ([name, name], [1])
     call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     sample = "simulations9"
     call global%set_string (var_str ("$sample"), &
          sample, is_known = .true.)
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     call simulation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize raw event file"
     write (u, "(A)")
 
     data%md5sum_prc = simulation%get_md5sum_prc ()
     data%md5sum_cfg = simulation%get_md5sum_cfg ()
     write (u, "(1x,A,A,A)")  "MD5 sum (proc)   = '", data%md5sum_prc, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (config) = '", data%md5sum_cfg, "'"
     call es_array%init (sample, [var_str ("raw")], global, &
          data)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate an event"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (1)
     call simulation%generate (es_array)
 
     call es_array%final ()
     call simulation%final ()
     deallocate (simulation)
 
     write (u, "(A)")  "* Initialize event generation for different parameters"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     allocate (simulation)
     call simulation%init ([procname1, procname1], .false., .false., global)
     call simulation%init_process_selector ()
 
     call simulation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Attempt to re-read the events (should fail)"
     write (u, "(A)")
 
     data%md5sum_prc = simulation%get_md5sum_prc ()
     data%md5sum_cfg = ""
     write (u, "(1x,A,A,A)")  "MD5 sum (proc)   = '", data%md5sum_prc, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (config) = '", data%md5sum_cfg, "'"
     call es_array%init (sample, empty_string_array, global, data, &
          input = var_str ("raw"), input_sample = sample, &
          allow_switch = .false., error = error)
 
     write (u, "(1x,A,L1)")  "error = ", error
 
     call simulation%rescan (1, es_array, global = global)
 
     call es_array%final ()
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_9"
 
   end subroutine simulations_9
 
 @ %def simulations_9
 @
 \subsubsection{Alternative weights}
 Generate an event for a single process and reweight it in a
 simultaneous calculation.
 <<Simulations: execute tests>>=
   call test (simulations_10, "simulations_10", &
        "alternative weight", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_10
 <<Simulations: tests>>=
   subroutine simulations_10 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, expr_text
     type(rt_data_t), target :: global
     type(rt_data_t), dimension(1), target :: alt_env
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: pt_weight
     type(simulation_t), target :: simulation
     type(event_sample_data_t) :: data
 
     write (u, "(A)")  "* Test output: simulations_10"
     write (u, "(A)")  "*   Purpose: reweight event"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize processes"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_pexpr_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_10a"
     procname1 = "simulation_10p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("simulations1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize alternative environment with custom weight"
     write (u, "(A)")
 
     call alt_env(1)%local_init (global)
     call alt_env(1)%activate ()
 
     expr_text = "2"
     write (u, "(A,A)")  "weight = ", char (expr_text)
     write (u, *)
 
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_weight, stream, .true.)
     call stream_final (stream)
     alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr ()
     call alt_env(1)%write_expr (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     call simulation%init ([procname1], .true., .true., global, alt_env=alt_env)
     call simulation%init_process_selector ()
 
     data = simulation%get_data ()
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate an event"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (1)
     call simulation%generate ()
     call simulation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write the event record for the last event"
     write (u, "(A)")
 
     call simulation%write_event (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write the event record for the alternative setup"
     write (u, "(A)")
 
     call simulation%write_alt_event (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call simulation%final ()
     call global%final ()
 
     call syntax_model_file_final ()
     call syntax_pexpr_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_10"
 
   end subroutine simulations_10
 
 @ %def simulations_10
 @
 \subsubsection{Decays}
 Generate an event with subsequent partonic decays.
 <<Simulations: execute tests>>=
   call test (simulations_11, "simulations_11", &
        "decay", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_11
 <<Simulations: tests>>=
   subroutine simulations_11 (u)
     integer, intent(in) :: u
     type(rt_data_t), target :: global
     type(prclib_entry_t), pointer :: lib
     type(string_t) :: prefix, procname1, procname2
     type(simulation_t), target :: simulation
 
     write (u, "(A)")  "* Test output: simulations_11"
     write (u, "(A)")  "*   Purpose: apply decay"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize processes"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     allocate (lib)
     call global%add_prclib (lib)
 
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     prefix = "simulation_11"
     procname1 = prefix // "_p"
     procname2 = prefix // "_d"
     call prepare_testbed &
          (global%prclib, global%process_stack, &
          prefix, global%os_data, &
          scattering=.true., decay=.true.)
 
     call global%select_model (var_str ("Test"))
     call global%model%set_par (var_str ("ff"), 0.4_default)
     call global%model%set_par (var_str ("mf"), &
          global%model%get_real (var_str ("ff")) &
          * global%model%get_real (var_str ("ms")))
     call global%model%set_unstable (25, [procname2])
 
     write (u, "(A)")  "* Initialize simulation object"
     write (u, "(A)")
 
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     write (u, "(A)")  "* Generate event"
     write (u, "(A)")
 
     call simulation%set_n_events_requested (1)
     call simulation%generate ()
     call simulation%write (u)
 
     write (u, *)
 
     call simulation%write_event (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     call simulation%final ()
     call global%final ()
 
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_11"
 
   end subroutine simulations_11
 
 @ %def simulations_11
 @
 \subsubsection{Split Event Files}
 Generate event for a real process with structure functions and write to file,
 accepting a limit for the number of events per file.
 <<Simulations: execute tests>>=
   call test (simulations_12, "simulations_12", &
        "split event files", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_12
 <<Simulations: tests>>=
   subroutine simulations_12 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, sample
     type(rt_data_t), target :: global
     class(eio_t), allocatable :: eio
     type(simulation_t), allocatable, target :: simulation
     type(flavor_t) :: flv
     integer :: i_evt
 
     write (u, "(A)")  "* Test output: simulations_12"
     write (u, "(A)")  "*   Purpose: generate events for a single process"
     write (u, "(A)")  "*            and write to split event files"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and integrate"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_12"
     procname1 = "simulation_12p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%model_set_real (var_str ("ms"), &
          0._default)
 
     call flv%init (25, global%model)
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     sample = "simulations_12"
     call global%set_string (var_str ("$sample"), &
          sample, is_known = .true.)
     call global%set_int (var_str ("sample_split_n_evt"), &
          2, is_known = .true.)
     call global%set_int (var_str ("sample_split_index"), &
          42, is_known = .true.)
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     call simulation%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize ASCII event file"
     write (u, "(A)")
 
     allocate (eio_ascii_short_t :: eio)
     select type (eio)
     class is (eio_ascii_t);  call eio%set_parameters ()
     end select
     call eio%init_out (sample, data = simulation%get_data ())
 
     write (u, "(A)")  "* Generate 5 events, distributed among three files"
 
     do i_evt = 1, 5
        call simulation%set_n_events_requested (1)
        call simulation%generate ()
        call simulation%write_event (eio)
     end do
 
     call eio%final ()
     deallocate (eio)
     call simulation%final ()
     deallocate (simulation)
 
     write (u, *)
     call display_file ("simulations_12.42.short.evt", u)
     write (u, *)
     call display_file ("simulations_12.43.short.evt", u)
     write (u, *)
     call display_file ("simulations_12.44.short.evt", u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_12"
 
   end subroutine simulations_12
 
 @ %def simulations_12
 @ Auxiliary: display file contents.
 <<Simulations: public test auxiliary>>=
   public :: display_file
 <<Simulations: test auxiliary>>=
   subroutine display_file (file, u)
     use io_units, only: free_unit
     character(*), intent(in) :: file
     integer, intent(in) :: u
     character(256) :: buffer
     integer :: u_file
     write (u, "(3A)")  "* Contents of file '", file, "':"
     write (u, *)
     u_file = free_unit ()
     open (u_file, file = file, action = "read", status = "old")
     do
        read (u_file, "(A)", end = 1)  buffer
        write (u, "(A)")  trim (buffer)
     end do
 1   continue
   end subroutine display_file
 
 @ %def display_file
 @
 \subsubsection{Callback}
 Generate events and execute a callback in place of event I/O.
 <<Simulations: execute tests>>=
   call test (simulations_13, "simulations_13", &
        "callback", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_13
 <<Simulations: tests>>=
   subroutine simulations_13 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, procname1, sample
     type(rt_data_t), target :: global
     class(eio_t), allocatable :: eio
     type(simulation_t), allocatable, target :: simulation
     type(flavor_t) :: flv
     integer :: i_evt
     type(simulations_13_callback_t) :: event_callback
 
     write (u, "(A)")  "* Test output: simulations_13"
     write (u, "(A)")  "*   Purpose: generate events for a single process"
     write (u, "(A)")  "*            and execute callback"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process and integrate"
     write (u, "(A)")
 
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
 
     libname = "simulation_13"
     procname1 = "simulation_13p"
 
     call prepare_test_library (global, libname, 1, [procname1])
     call compile_library (libname, global)
 
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
 
     call global%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known = .true.)
     call global%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call global%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known = .true.)
     call global%set_log (var_str ("?vis_history"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
 
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
 
     call flv%init (25, global%model)
 
     call global%it_list%init ([1], [1000])
 
     call global%set_string (var_str ("$run_id"), &
          var_str ("r1"), is_known = .true.)
     call integrate_process (procname1, global, local_stack=.true.)
 
     write (u, "(A)")  "* Initialize event generation"
     write (u, "(A)")
 
     call global%set_log (var_str ("?unweighted"), &
          .false., is_known = .true.)
     sample = "simulations_13"
     call global%set_string (var_str ("$sample"), &
          sample, is_known = .true.)
 
     allocate (simulation)
     call simulation%init ([procname1], .true., .true., global)
     call simulation%init_process_selector ()
 
     write (u, "(A)")  "* Prepare callback object"
     write (u, "(A)")
 
     event_callback%u = u
     call global%set_event_callback (event_callback)
 
     write (u, "(A)")  "* Initialize callback I/O object"
     write (u, "(A)")
 
     allocate (eio_callback_t :: eio)
     select type (eio)
     class is (eio_callback_t)
        call eio%set_parameters (callback = event_callback, &
             count_interval = 3)
     end select
     call eio%init_out (sample, data = simulation%get_data ())
 
     write (u, "(A)")  "* Generate 7 events, with callback every 3 events"
     write (u, "(A)")
 
     do i_evt = 1, 7
        call simulation%set_n_events_requested (1)
        call simulation%generate ()
        call simulation%write_event (eio)
     end do
 
     call eio%final ()
     deallocate (eio)
     call simulation%final ()
     deallocate (simulation)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_13"
 
   end subroutine simulations_13
 
 @ %def simulations_13
 @ The callback object and procedure.  In the type extension, we can
 store the output channel [[u]] so we know where to write into.
 <<Simulations: test auxiliary types>>=
   type, extends (event_callback_t) :: simulations_13_callback_t
      integer :: u
    contains
      procedure :: write => simulations_13_callback_write
      procedure :: proc => simulations_13_callback
   end type simulations_13_callback_t
 
 @ %def simulations_13_callback_t
 <<Simulations: test auxiliary>>=
   subroutine simulations_13_callback_write (event_callback, unit)
     class(simulations_13_callback_t), intent(in) :: event_callback
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Hello"
   end subroutine simulations_13_callback_write
 
   subroutine simulations_13_callback (event_callback, i, event)
     class(simulations_13_callback_t), intent(in) :: event_callback
     integer(i64), intent(in) :: i
     class(generic_event_t), intent(in) :: event
     write (event_callback%u, "(A,I0)")  "hello event #", i
   end subroutine simulations_13_callback
 
 @ %def simulations_13_callback_write
 @ %def simulations_13_callback
 @
 \subsubsection{Resonant subprocess setup}
 Prepare a process with resonances and enter resonant subprocesses in
 the simulation object.  Select a kinematics configuration and compute
 probabilities for resonant subprocesses.
 
 The process and its initialization is taken from [[processes_18]], but
 we need a complete \oMega\ matrix element here.
 <<Simulations: execute tests>>=
   call test (simulations_14, "simulations_14", &
        "resonant subprocesses evaluation", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_14
 <<Simulations: tests>>=
   subroutine simulations_14 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, libname_generated
     type(string_t) :: procname
     type(string_t) :: model_name
     type(rt_data_t), target :: global
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     class(model_t), pointer :: model
     class(model_data_t), pointer :: model_data
     type(simulation_t), target :: simulation
     type(particle_set_t) :: pset
     type(eio_direct_t) :: eio_in
     type(eio_dump_t) :: eio_out
     real(default) :: sqrts, mw, pp
     real(default), dimension(3) :: p3
     type(vector4_t), dimension(:), allocatable :: p
     real(default), dimension(:), allocatable :: m
     integer :: u_verbose, i
     real(default) :: sqme_proc
     real(default), dimension(:), allocatable :: sqme
     real(default) :: on_shell_limit
     integer, dimension(:), allocatable :: i_array
     real(default), dimension(:), allocatable :: prob_array
 
     write (u, "(A)")  "* Test output: simulations_14"
     write (u, "(A)")  "*   Purpose: construct resonant subprocesses &
          &in the simulation object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     libname = "simulations_14_lib"
     procname = "simulations_14_p"
 
     call global%global_init ()
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
     call global%set_log (var_str ("?update_sqme"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?update_weight"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?update_event"), &
          .true., is_known = .true.)
 
     model_name = "SM"
     call global%select_model (model_name)
     allocate (model)
     call model%init_instance (global%model)
     model_data => model
 
     write (u, "(A)")  "* Initialize process library and process"
     write (u, "(A)")
 
     allocate (lib_entry)
     call lib_entry%init (libname)
     lib => lib_entry%process_library_t
     call global%add_prclib (lib_entry)
 
     call prepare_resonance_test_library &
          (lib, libname, procname, model_data, global, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize simulation object &
          &with resonant subprocesses"
     write (u, "(A)")
 
     call global%set_log (var_str ("?resonance_history"), &
          .true., is_known = .true.)
     call global%set_real (var_str ("resonance_on_shell_limit"), &
          10._default, is_known = .true.)
 
     call simulation%init ([procname], &
          integrate=.false., generate=.false., local=global)
 
     call simulation%write_resonant_subprocess_data (u, 1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Resonant subprocesses: generated library"
     write (u, "(A)")
 
     libname_generated = procname // "_R"
     lib => global%prclib_stack%get_library_ptr (libname_generated)
     if (associated (lib))  call lib%write (u, libpath=.false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generated process stack"
     write (u, "(A)")
 
     call global%process_stack%show (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle set"
     write (u, "(A)")
 
     pset = simulation%get_hard_particle_set (1)
     call pset%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize object for direct access"
     write (u, "(A)")
 
     call eio_in%init_direct &
          (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, &
          pdg = [-11, 11, 1, -2, 24], model=global%model)
     call eio_in%set_selection_indices (1, 1, 1, 1)
 
     sqrts = global%get_rval (var_str ("sqrts"))
     mw = 80._default   ! deliberately slightly different from true mw
     pp = sqrt (sqrts**2 - 4 * mw**2) / 2
 
     allocate (p (5), m (5))
     p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
     m(1) = 0
     p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
     m(2) = 0
     p3(1) = pp/2
     p3(2) = mw/2
     p3(3) = 0
     p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(3) = 0
     p3(2) = -mw/2
     p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
     m(4) = 0
     p(5) = vector4_moving (sqrts/2,-pp, 1)
     m(5) = mw
     call eio_in%set_momentum (p, m**2)
 
     call eio_in%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Transfer and show particle set"
     write (u, "(A)")
 
     call simulation%read_event (eio_in)
     pset = simulation%get_hard_particle_set (1)
     call pset%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (Re)calculate matrix element"
     write (u, "(A)")
 
     call simulation%recalculate (recover_phs = .false.)
     call simulation%evaluate_transforms ()
 
     write (u, "(A)")  "* Show event with sqme"
     write (u, "(A)")
 
     call eio_out%set_parameters (unit = u, &
          weights = .true., pacify = .true., compressed = .true.)
     call eio_out%init_out (var_str (""))
     call simulation%write_event (eio_out)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write event to separate file &
          &'simulations_14_event_verbose.log'"
 
     u_verbose = free_unit ()
     open (unit = u_verbose, file = "simulations_14_event_verbose.log", &
          status = "replace", action = "write")
     call simulation%write (u_verbose)
     write (u_verbose, *)
     call simulation%write_event (u_verbose, verbose =.true., testflag = .true.)
     close (u_verbose)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_14"
 
   end subroutine simulations_14
 
 @ %def simulations_14
 @
 \subsubsection{Resonant subprocess simulation}
 Prepare a process with resonances and enter resonant subprocesses in
 the simulation object.  Simulate events with selection of resonance
 histories.
 
 The process and its initialization is taken from [[processes_18]], but
 we need a complete \oMega\ matrix element here.
 <<Simulations: execute tests>>=
   call test (simulations_15, "simulations_15", &
        "resonant subprocesses in simulation", &
        u, results)
 <<Simulations: test declarations>>=
   public :: simulations_15
 <<Simulations: tests>>=
   subroutine simulations_15 (u)
     integer, intent(in) :: u
     type(string_t) :: libname, libname_generated
     type(string_t) :: procname
     type(string_t) :: model_name
     type(rt_data_t), target :: global
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     class(model_t), pointer :: model
     class(model_data_t), pointer :: model_data
     type(simulation_t), target :: simulation
     real(default) :: sqrts
     type(eio_dump_t) :: eio_out
     integer :: u_verbose
 
     write (u, "(A)")  "* Test output: simulations_15"
     write (u, "(A)")  "*   Purpose: generate event with resonant subprocess"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_phs_forest_init ()
 
     libname = "simulations_15_lib"
     procname = "simulations_15_p"
 
     call global%global_init ()
     call global%append_log (&
          var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_grids"), .true., intrinsic = .true.)
     call global%append_log (&
          var_str ("?rebuild_events"), .true., intrinsic = .true.)
     call global%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     call global%set_int (var_str ("seed"), &
          0, is_known = .true.)
     call global%set_real (var_str ("sqrts"),&
          1000._default, is_known = .true.)
     call global%set_log (var_str ("?recover_beams"), &
          .false., is_known = .true.)
     call global%set_log (var_str ("?update_sqme"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?update_weight"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?update_event"), &
          .true., is_known = .true.)
     call global%set_log (var_str ("?resonance_history"), &
          .true., is_known = .true.)
     call global%set_real (var_str ("resonance_on_shell_limit"), &
          10._default, is_known = .true.)
 
     model_name = "SM"
     call global%select_model (model_name)
     allocate (model)
     call model%init_instance (global%model)
     model_data => model
 
     write (u, "(A)")  "* Initialize process library and process"
     write (u, "(A)")
 
     allocate (lib_entry)
     call lib_entry%init (libname)
     lib => lib_entry%process_library_t
     call global%add_prclib (lib_entry)
 
     call prepare_resonance_test_library &
          (lib, libname, procname, model_data, global, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize simulation object &
          &with resonant subprocesses"
     write (u, "(A)")
 
     call global%it_list%init ([1], [1000])
     call simulation%init ([procname], &
          integrate=.true., generate=.true., local=global)
 
     call simulation%write_resonant_subprocess_data (u, 1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate event"
     write (u, "(A)")
 
     call simulation%init_process_selector ()
     call simulation%set_n_events_requested (1)
     call simulation%generate ()
 
     call eio_out%set_parameters (unit = u, &
          weights = .true., pacify = .true., compressed = .true.)
     call eio_out%init_out (var_str (""))
     call simulation%write_event (eio_out)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write event to separate file &
          &'simulations_15_event_verbose.log'"
 
     u_verbose = free_unit ()
     open (unit = u_verbose, file = "simulations_15_event_verbose.log", &
          status = "replace", action = "write")
     call simulation%write (u_verbose)
     write (u_verbose, *)
     call simulation%write_event (u_verbose, verbose =.true., testflag = .true.)
     close (u_verbose)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call simulation%final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: simulations_15"
 
   end subroutine simulations_15
 
 @ %def simulations_15
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{More Unit Tests}
 
 This chapter collects some procedures for testing that can't be
 provided at the point where the corresponding modules are defined,
 because they use other modules of a different level.
 
 (We should move them back, collecting the high-level functionality in
 init/final hooks that we can set at runtime.)
 
 
 \section{Expression Testing}
 
 Expression objects are part of process and event objects, but the
 process and event object modules should not depend on the
 implementation of expressions.  Here, we collect unit tests that
 depend on expression implementation.
 <<[[expr_tests_ut.f90]]>>=
 <<File header>>
 module expr_tests_ut
 
   use unit_tests
   use expr_tests_uti
 
 <<Standard module head>>
 
 <<Expr tests: public test>>
 
 contains
 
 <<Expr tests: test driver>>
 
 end module expr_tests_ut
 @ %def expr_tests_ut
 @
 <<[[expr_tests_uti.f90]]>>=
 <<File header>>
 
 module expr_tests_uti
 
   <<Use kinds>>
   <<Use strings>>
     use format_defs, only: FMT_12
     use format_utils, only: write_separator
     use os_interface
     use sm_qcd
     use lorentz
     use ifiles
     use lexers
     use parser
     use model_data
     use interactions, only: reset_interaction_counter
     use process_libraries
     use subevents
     use subevt_expr
     use rng_base
     use mci_base
     use phs_base
     use variables, only: var_list_t
     use eval_trees
     use models
     use prc_core
     use prc_test
     use process, only: process_t
     use instances, only: process_instance_t
     use events
 
     use rng_base_ut, only: rng_test_factory_t
     use phs_base_ut, only: phs_test_config_t
 
 <<Standard module head>>
 
 <<Expr tests: test declarations>>
 
 contains
 
 <<Expr tests: tests>>
 
 <<Expr tests: test auxiliary>>
 
 end module expr_tests_uti
 
 @ %def expr_tests_uti
 @
 \subsection{Test}
 This is the master for calling self-test procedures.
 <<Expr tests: public test>>=
   public :: subevt_expr_test
 <<Expr tests: test driver>>=
   subroutine subevt_expr_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Expr tests: execute tests>>
 end subroutine subevt_expr_test
 
 @ %def subevt_expr_test
 @
 \subsubsection{Parton-event expressions}
 <<Expr tests: execute tests>>=
   call test (subevt_expr_1, "subevt_expr_1", &
        "parton-event expressions", &
        u, results)
 <<Expr tests: test declarations>>=
   public :: subevt_expr_1
 <<Expr tests: tests>>=
   subroutine subevt_expr_1 (u)
     integer, intent(in) :: u
     type(string_t) :: expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: pt_cuts, pt_scale, pt_fac_scale, pt_ren_scale
     type(parse_tree_t) :: pt_weight
     type(parse_node_t), pointer :: pn_cuts, pn_scale, pn_fac_scale, pn_ren_scale
     type(parse_node_t), pointer :: pn_weight
     type(eval_tree_factory_t) :: expr_factory
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(parton_expr_t), target :: expr
     real(default) :: E, Ex, m
     type(vector4_t), dimension(6) :: p
     integer :: i, pdg
     logical :: passed
     real(default) :: scale, fac_scale, ren_scale, weight
 
     write (u, "(A)")  "* Test output: subevt_expr_1"
     write (u, "(A)")  "*   Purpose: Set up a subevt and associated &
          &process-specific expressions"
     write (u, "(A)")
 
     call syntax_pexpr_init ()
 
     call syntax_model_file_init ()
     call os_data%init ()
     call model%read (var_str ("Test.mdl"), os_data)
 
     write (u, "(A)")  "* Expression texts"
     write (u, "(A)")
 
 
     expr_text = "all Pt > 100 [s]"
     write (u, "(A,A)")  "cuts = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (pt_cuts, stream, .true.)
     call stream_final (stream)
     pn_cuts => pt_cuts%get_root_ptr ()
 
     expr_text = "sqrts"
     write (u, "(A,A)")  "scale = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_scale, stream, .true.)
     call stream_final (stream)
     pn_scale => pt_scale%get_root_ptr ()
 
     expr_text = "sqrts_hat"
     write (u, "(A,A)")  "fac_scale = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_fac_scale, stream, .true.)
     call stream_final (stream)
     pn_fac_scale => pt_fac_scale%get_root_ptr ()
 
     expr_text = "100"
     write (u, "(A,A)")  "ren_scale = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_ren_scale, stream, .true.)
     call stream_final (stream)
     pn_ren_scale => pt_ren_scale%get_root_ptr ()
 
     expr_text = "n_tot - n_in - n_out"
     write (u, "(A,A)")  "weight = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_weight, stream, .true.)
     call stream_final (stream)
     pn_weight => pt_weight%get_root_ptr ()
 
     call ifile_final (ifile)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize process expr"
     write (u, "(A)")
 
     call expr%setup_vars (1000._default)
     call expr%var_list%append_real (var_str ("tolerance"), 0._default)
     call expr%link_var_list (model%get_var_list_ptr ())
 
     call expr_factory%init (pn_cuts)
     call expr%setup_selection (expr_factory)
     call expr_factory%init (pn_scale)
     call expr%setup_scale (expr_factory)
     call expr_factory%init (pn_fac_scale)
     call expr%setup_fac_scale (expr_factory)
     call expr_factory%init (pn_ren_scale)
     call expr%setup_ren_scale (expr_factory)
     call expr_factory%init (pn_weight)
     call expr%setup_weight (expr_factory)
 
     call write_separator (u)
     call expr%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Fill subevt and evaluate expressions"
     write (u, "(A)")
 
     call subevt_init (expr%subevt_t, 6)
     E = 500._default
     Ex = 400._default
     m = 125._default
     pdg = 25
     p(1) = vector4_moving (E, sqrt (E**2 - m**2), 3)
     p(2) = vector4_moving (E, -sqrt (E**2 - m**2), 3)
     p(3) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 3)
     p(4) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 3)
     p(5) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 1)
     p(6) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 1)
 
     call expr%reset_contents ()
     do i = 1, 2
        call subevt_set_beam (expr%subevt_t, i, pdg, p(i), m**2)
     end do
     do i = 3, 4
        call subevt_set_incoming (expr%subevt_t, i, pdg, p(i), m**2)
     end do
     do i = 5, 6
        call subevt_set_outgoing (expr%subevt_t, i, pdg, p(i), m**2)
     end do
     expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
     expr%n_in = 2
     expr%n_out = 2
     expr%n_tot = 4
     expr%subevt_filled = .true.
 
     call expr%evaluate (passed, scale, fac_scale, ren_scale, weight)
 
     write (u, "(A,L1)")      "Event has passed      = ", passed
     write (u, "(A," // FMT_12 // ")")  "Scale                 = ", scale
     write (u, "(A," // FMT_12 // ")")  "Factorization scale   = ", fac_scale
     write (u, "(A," // FMT_12 // ")")  "Renormalization scale = ", ren_scale
     write (u, "(A," // FMT_12 // ")")  "Weight                = ", weight
     write (u, "(A)")
 
     call write_separator (u)
     call expr%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call expr%final ()
 
     call model%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: subevt_expr_1"
 
   end subroutine subevt_expr_1
 
 @ %def subevt_expr_1
 @
 \subsubsection{Parton-event expressions}
 <<Expr tests: execute tests>>=
   call test (subevt_expr_2, "subevt_expr_2", &
        "parton-event expressions", &
        u, results)
 <<Expr tests: test declarations>>=
   public :: subevt_expr_2
 <<Expr tests: tests>>=
   subroutine subevt_expr_2 (u)
     integer, intent(in) :: u
     type(string_t) :: expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: pt_selection
     type(parse_tree_t) :: pt_reweight, pt_analysis
     type(parse_node_t), pointer :: pn_selection
     type(parse_node_t), pointer :: pn_reweight, pn_analysis
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(eval_tree_factory_t) :: expr_factory
     type(event_expr_t), target :: expr
     real(default) :: E, Ex, m
     type(vector4_t), dimension(6) :: p
     integer :: i, pdg
     logical :: passed
     real(default) :: reweight
     logical :: analysis_flag
 
     write (u, "(A)")  "* Test output: subevt_expr_2"
     write (u, "(A)")  "*   Purpose: Set up a subevt and associated &
          &process-specific expressions"
     write (u, "(A)")
 
     call syntax_pexpr_init ()
 
     call syntax_model_file_init ()
     call os_data%init ()
     call model%read (var_str ("Test.mdl"), os_data)
 
     write (u, "(A)")  "* Expression texts"
     write (u, "(A)")
 
 
     expr_text = "all Pt > 100 [s]"
     write (u, "(A,A)")  "selection = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (pt_selection, stream, .true.)
     call stream_final (stream)
     pn_selection => pt_selection%get_root_ptr ()
 
     expr_text = "n_tot - n_in - n_out"
     write (u, "(A,A)")  "reweight = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_reweight, stream, .true.)
     call stream_final (stream)
     pn_reweight => pt_reweight%get_root_ptr ()
 
     expr_text = "true"
     write (u, "(A,A)")  "analysis = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (pt_analysis, stream, .true.)
     call stream_final (stream)
     pn_analysis => pt_analysis%get_root_ptr ()
 
     call ifile_final (ifile)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize process expr"
     write (u, "(A)")
 
     call expr%setup_vars (1000._default)
     call expr%link_var_list (model%get_var_list_ptr ())
     call expr%var_list%append_real (var_str ("tolerance"), 0._default)
 
     call expr_factory%init (pn_selection)
     call expr%setup_selection (expr_factory)
     call expr_factory%init (pn_analysis)
     call expr%setup_analysis (expr_factory)
     call expr_factory%init (pn_reweight)
     call expr%setup_reweight (expr_factory)
 
     call write_separator (u)
     call expr%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Fill subevt and evaluate expressions"
     write (u, "(A)")
 
     call subevt_init (expr%subevt_t, 6)
     E = 500._default
     Ex = 400._default
     m = 125._default
     pdg = 25
     p(1) = vector4_moving (E, sqrt (E**2 - m**2), 3)
     p(2) = vector4_moving (E, -sqrt (E**2 - m**2), 3)
     p(3) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 3)
     p(4) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 3)
     p(5) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 1)
     p(6) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 1)
 
     call expr%reset_contents ()
     do i = 1, 2
        call subevt_set_beam (expr%subevt_t, i, pdg, p(i), m**2)
     end do
     do i = 3, 4
        call subevt_set_incoming (expr%subevt_t, i, pdg, p(i), m**2)
     end do
     do i = 5, 6
        call subevt_set_outgoing (expr%subevt_t, i, pdg, p(i), m**2)
     end do
     expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
     expr%n_in = 2
     expr%n_out = 2
     expr%n_tot = 4
     expr%subevt_filled = .true.
 
     call expr%evaluate (passed, reweight, analysis_flag)
 
     write (u, "(A,L1)")      "Event has passed      = ", passed
     write (u, "(A," // FMT_12 // ")")  "Reweighting factor    = ", reweight
     write (u, "(A,L1)")      "Analysis flag         = ", analysis_flag
     write (u, "(A)")
 
     call write_separator (u)
     call expr%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call expr%final ()
 
     call model%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: subevt_expr_2"
 
   end subroutine subevt_expr_2
 
 @ %def subevt_expr_2
 @
 \subsubsection{Processes: handle partonic cuts}
 Initialize a process and process instance, choose a sampling point and
 fill the process instance, evaluating a given cut configuration.
 
 We use the same trivial process as for the previous test.  All
 momentum and state dependence is trivial, so we just test basic
 functionality.
 <<Expr tests: execute tests>>=
   call test (processes_5, "processes_5", &
        "handle cuts (partonic event)", &
        u, results)
 <<Expr tests: test declarations>>=
   public :: processes_5
 <<Expr tests: tests>>=
   subroutine processes_5 (u)
     integer, intent(in) :: u
     type(string_t) :: cut_expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: parse_tree
     type(eval_tree_factory_t) :: expr_factory
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), pointer :: model_tmp
     type(model_t), pointer :: model
     type(var_list_t), target :: var_list
     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
 
     write (u, "(A)")  "* Test output: processes_5"
     write (u, "(A)")  "*   Purpose: create a process &
          &and fill a process instance"
     write (u, "(A)")
 
     write (u, "(A)")  "* Prepare a cut expression"
     write (u, "(A)")
 
     call syntax_pexpr_init ()
     cut_expr_text = "all Pt > 100 [s]"
     call ifile_append (ifile, cut_expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (parse_tree, stream, .true.)
 
     write (u, "(A)")  "* Build and initialize a test process"
     write (u, "(A)")
 
     libname = "processes5"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call syntax_model_file_init ()
     allocate (model_tmp)
     call model_tmp%read (var_str ("Test.mdl"), os_data)
     call var_list%init_snapshot (model_tmp%get_var_list_ptr ())
     model => model_tmp
 
     call reset_interaction_counter ()
 
     call var_list%append_real (var_str ("tolerance"), 0._default)
     call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
     call var_list%append_int (var_str ("seed"), 0)
 
     allocate (process)
     call process%init (procname, lib, os_data, model, var_list)
 
     call var_list%final ()
 
     allocate (phs_test_config_t :: phs_config_template)
     call process%setup_test_cores ()
     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 and set cuts"
     write (u, "(A)")
 
     call process%setup_terms ()
     call expr_factory%init (parse_tree%get_root_ptr ())
     call process%set_cuts (expr_factory)
     call process%write (.false., u, &
          show_var_list=.true., show_expressions=.true., show_os_data=.false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     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])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up kinematics and subevt, check cuts (should fail)"
     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 ()
 
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for another set (should succeed)"
     write (u, "(A)")
 
     call process_instance%reset ()
     call process_instance%set_mcpar ([0.5_default, 0.125_default])
     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 ()
     call process_instance%evaluate_trace ()
 
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for another set using convenience procedure &
          &(failure)"
     write (u, "(A)")
 
     call process_instance%evaluate_sqme (1, [0.0_default, 0.2_default])
 
     call process_instance%write_header (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for another set using convenience procedure &
          &(success)"
     write (u, "(A)")
 
     call process_instance%evaluate_sqme (1, [0.1_default, 0.2_default])
 
     call process_instance%write_header (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call parse_tree_final (parse_tree)
     call stream_final (stream)
     call ifile_final (ifile)
     call syntax_pexpr_final ()
 
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_5"
 
   end subroutine processes_5
 
 @ %def processes_5
 @ Trivial for testing: do not allocate the MCI record.
 <<Expr tests: 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{Processes: scales and such}
 Initialize a process and process instance, choose a sampling point and
 fill the process instance, evaluating a given cut configuration.
 
 We use the same trivial process as for the previous test.  All
 momentum and state dependence is trivial, so we just test basic
 functionality.
 <<Expr tests: execute tests>>=
   call test (processes_6, "processes_6", &
        "handle scales and weight (partonic event)", &
        u, results)
 <<Expr tests: test declarations>>=
   public :: processes_6
 <<Expr tests: tests>>=
   subroutine processes_6 (u)
     integer, intent(in) :: u
     type(string_t) :: expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: pt_scale, pt_fac_scale, pt_ren_scale, pt_weight
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), pointer :: model_tmp
     type(model_t), pointer :: model
     type(var_list_t), target :: var_list
     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(eval_tree_factory_t) :: expr_factory
 
     write (u, "(A)")  "* Test output: processes_6"
     write (u, "(A)")  "*   Purpose: create a process &
          &and fill a process instance"
     write (u, "(A)")
 
     write (u, "(A)")  "* Prepare expressions"
     write (u, "(A)")
 
     call syntax_pexpr_init ()
 
     expr_text = "sqrts - 100 GeV"
     write (u, "(A,A)")  "scale = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_scale, stream, .true.)
     call stream_final (stream)
 
     expr_text = "sqrts_hat"
     write (u, "(A,A)")  "fac_scale = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_fac_scale, stream, .true.)
     call stream_final (stream)
 
     expr_text = "eval sqrt (M2) [collect [s]]"
     write (u, "(A,A)")  "ren_scale = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_ren_scale, stream, .true.)
     call stream_final (stream)
 
     expr_text = "n_tot * n_in * n_out * (eval Phi / pi [s])"
     write (u, "(A,A)")  "weight = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_weight, stream, .true.)
     call stream_final (stream)
 
     call ifile_final (ifile)
 
     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 syntax_model_file_init ()
     allocate (model_tmp)
     call model_tmp%read (var_str ("Test.mdl"), os_data)
     call var_list%init_snapshot (model_tmp%get_var_list_ptr ())
     model => model_tmp
 
     call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
     call var_list%append_int (var_str ("seed"), 0)
 
     call reset_interaction_counter ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model, var_list)
 
     call var_list%final ()
 
     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 and set cuts"
     write (u, "(A)")
 
     call process%setup_terms ()
     call expr_factory%init (pt_scale%get_root_ptr ())
     call process%set_scale (expr_factory)
     call expr_factory%init (pt_fac_scale%get_root_ptr ())
     call process%set_fac_scale (expr_factory)
     call expr_factory%init (pt_ren_scale%get_root_ptr ())
     call process%set_ren_scale (expr_factory)
     call expr_factory%init (pt_weight%get_root_ptr ())
     call process%set_weight (expr_factory)
     call process%write (.false., u, show_expressions=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance and evaluate"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%choose_mci (1)
     call process_instance%evaluate_sqme (1, [0.5_default, 0.125_default])
 
     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 parse_tree_final (pt_scale)
     call parse_tree_final (pt_fac_scale)
     call parse_tree_final (pt_ren_scale)
     call parse_tree_final (pt_weight)
     call syntax_pexpr_final ()
 
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_6"
 
   end subroutine processes_6
 
 @ %def processes_6
 @
 \subsubsection{Event expressions}
 After generating an event, fill the [[subevt]] and evaluate expressions for
 selection, reweighting, and analysis.
 <<Expr tests: execute tests>>=
   call test (events_3, "events_3", &
        "expression evaluation", &
        u, results)
 <<Expr tests: test declarations>>=
   public :: events_3
 <<Expr tests: tests>>=
   subroutine events_3 (u)
     use processes_ut, only: prepare_test_process, cleanup_test_process
     integer, intent(in) :: u
     type(string_t) :: expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(parse_tree_t) :: pt_selection, pt_reweight, pt_analysis
     type(eval_tree_factory_t) :: expr_factory
     type(event_t), allocatable, target :: event
     type(process_t), allocatable, target :: process
     type(process_instance_t), allocatable, target :: process_instance
     type(os_data_t) :: os_data
     type(model_t), pointer :: model
     type(var_list_t), target :: var_list
 
     write (u, "(A)")  "* Test output: events_3"
     write (u, "(A)")  "*   Purpose: generate an event and evaluate expressions"
     write (u, "(A)")
 
     call syntax_pexpr_init ()
 
     write (u, "(A)")  "* Expression texts"
     write (u, "(A)")
 
     expr_text = "all Pt > 100 [s]"
     write (u, "(A,A)")  "selection = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (pt_selection, stream, .true.)
     call stream_final (stream)
 
     expr_text = "1 + sqrts_hat / sqrts"
     write (u, "(A,A)")  "reweight = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_expr (pt_reweight, stream, .true.)
     call stream_final (stream)
 
     expr_text = "true"
     write (u, "(A,A)")  "analysis = ", char (expr_text)
     call ifile_clear (ifile)
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call parse_tree_init_lexpr (pt_analysis, stream, .true.)
     call stream_final (stream)
 
     call ifile_final (ifile)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize test process event"
 
     call os_data%init ()
 
     call syntax_model_file_init ()
     allocate (model)
     call model%read (var_str ("Test.mdl"), os_data)
     call var_list%init_snapshot (model%get_var_list_ptr ())
 
     call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
     call var_list%append_int (var_str ("seed"), 0)
 
     allocate (process)
     allocate (process_instance)
     call prepare_test_process (process, process_instance, model, var_list)
 
     call var_list%final ()
 
     call process_instance%setup_event_data ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize event object and set expressions"
 
     allocate (event)
     call event%basic_init ()
 
     call expr_factory%init (pt_selection%get_root_ptr ())
     call event%set_selection (expr_factory)
     call expr_factory%init (pt_reweight%get_root_ptr ())
     call event%set_reweight (expr_factory)
     call expr_factory%init (pt_analysis%get_root_ptr ())
     call event%set_analysis (expr_factory)
 
     call event%connect (process_instance, process%get_model_ptr ())
     call event%expr%var_list%append_real (var_str ("tolerance"), 0._default)
     call event%setup_expressions ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate test process event"
 
     call process_instance%generate_weighted_event (1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Fill event object and evaluate expressions"
     write (u, "(A)")
 
     call event%generate (1, [0.4_default, 0.4_default])
     call event%set_index (42)
     call event%evaluate_expressions ()
     call event%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call event%final ()
     deallocate (event)
 
     call cleanup_test_process (process, process_instance)
     deallocate (process_instance)
     deallocate (process)
 
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: events_3"
 
   end subroutine events_3
 
 @ %def events_3
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Top Level}
 
 The top level consists of
 \begin{description}
 \item[commands]
   Defines generic command-list and command objects, and all specific
   implementations.  Each command type provides a specific
   functionality.  Together with the modules that provide expressions
   and variables, this module defines the Sindarin language.
 \item[whizard]
   This module interprets streams of various kind in terms of the
   command language.  It also contains the unit-test feature.  We also
   define the externally visible procedures here, for the \whizard\ as
   a library.
 \item[main]
   The driver for \whizard\ as a stand-alone program.  Contains the
   command-line interpreter.
 \item[whizard\_c\_interface]
   Alternative top-level procedures, for use in the context of a
   C-compatible caller program.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Commands}
 This module defines the command language of the main input file.
 <<[[commands.f90]]>>=
 <<File header>>
 
 module commands
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use string_utils, only: lower_case, split_string, str
   use format_utils, only: write_indent
   use format_defs, only: FMT_14, FMT_19
   use diagnostics
 
   use constants, only: one
   use physics_defs
   use sorting
   use sf_lhapdf, only: lhapdf_global_reset
   use os_interface
   use ifiles
   use lexers
   use syntax_rules
   use parser
   use analysis
   use pdg_arrays
   use variables, only: var_list_t, V_NONE, V_LOG, V_INT, V_REAL, V_CMPLX, V_STR, V_PDG
   use observables, only: var_list_check_observable
   use observables, only: var_list_check_result_var
   use eval_trees
   use models
   use auto_components
   use flavors
   use polarizations
   use particle_specifiers
   use process_libraries
   use process
   use instances
   use prclib_stacks
   use slha_interface
   use user_files
   use eio_data
   use rt_data
 
   use process_configurations
   use compilations, only: compile_library, compile_executable
   use integrations, only: integrate_process
   use restricted_subprocesses, only: get_libname_res
   use restricted_subprocesses, only: spawn_resonant_subprocess_libraries
   use event_streams
   use simulations
 
   use radiation_generator
 
 <<Use mpi f08>>
 
 <<Standard module head>>
 
 <<Commands: public>>
 
 <<Commands: types>>
 
 <<Commands: variables>>
 
 <<Commands: parameters>>
 
 <<Commands: interfaces>>
 
 contains
 
 <<Commands: procedures>>
 
 end module commands
 @ %def commands
 @
 \subsection{The command type}
 The command type is a generic type that holds any command, compiled
 for execution.
 
 Each command may come with its own local environment.  The command list that
 determines this environment is allocated as [[options]], if necessary.  (It
 has to be allocated as a pointer because the type definition is recursive.) The
 local environment is available as a pointer which either points to the global
 environment, or is explicitly allocated and initialized.
 <<Commands: types>>=
   type, abstract :: command_t
      type(parse_node_t), pointer :: pn => null ()
      class(command_t), pointer :: next => null ()
      type(parse_node_t), pointer :: pn_opt => null ()
      type(command_list_t), pointer :: options => null ()
      type(rt_data_t), pointer :: local => null ()
    contains
    <<Commands: command: TBP>>
   end type command_t
 
 @ %def command_t
 @ Finalizer: If there is an option list, finalize the option list and
 deallocate.  If not, the local environment is just a pointer.
 <<Commands: command: TBP>>=
   procedure :: final => command_final
 <<Commands: procedures>>=
   recursive subroutine command_final (cmd)
     class(command_t), intent(inout) :: cmd
     if (associated (cmd%options)) then
        call cmd%options%final ()
        deallocate (cmd%options)
        call cmd%local%local_final ()
        deallocate (cmd%local)
     else
        cmd%local => null ()
     end if
   end subroutine command_final
 
 @ %def command_final
 @ Allocate a command with the appropriate concrete type.  Store the
 parse node pointer in the command object, so we can reference to it
 when compiling.
 <<Commands: procedures>>=
   subroutine dispatch_command (command, pn)
     class(command_t), intent(inout), pointer :: command
     type(parse_node_t), intent(in), target :: pn
     select case (char (parse_node_get_rule_key (pn)))
     case ("cmd_model")
        allocate (cmd_model_t :: command)
     case ("cmd_library")
        allocate (cmd_library_t :: command)
     case ("cmd_process")
        allocate (cmd_process_t :: command)
     case ("cmd_nlo")
        allocate (cmd_nlo_t :: command)
     case ("cmd_compile")
        allocate (cmd_compile_t :: command)
     case ("cmd_exec")
        allocate (cmd_exec_t :: command)
      case ("cmd_num", "cmd_complex", "cmd_real", "cmd_int", &
            "cmd_log_decl", "cmd_log", "cmd_string", "cmd_string_decl", &
            "cmd_alias", "cmd_result")
        allocate (cmd_var_t :: command)
     case ("cmd_slha")
        allocate (cmd_slha_t :: command)
     case ("cmd_show")
        allocate (cmd_show_t :: command)
     case ("cmd_clear")
        allocate (cmd_clear_t :: command)
     case ("cmd_expect")
        allocate (cmd_expect_t :: command)
     case ("cmd_beams")
        allocate (cmd_beams_t :: command)
     case ("cmd_beams_pol_density")
        allocate (cmd_beams_pol_density_t :: command)
     case ("cmd_beams_pol_fraction")
        allocate (cmd_beams_pol_fraction_t :: command)
     case ("cmd_beams_momentum")
        allocate (cmd_beams_momentum_t :: command)
     case ("cmd_beams_theta")
        allocate (cmd_beams_theta_t :: command)
     case ("cmd_beams_phi")
        allocate (cmd_beams_phi_t :: command)
     case ("cmd_cuts")
        allocate (cmd_cuts_t :: command)
     case ("cmd_scale")
        allocate (cmd_scale_t :: command)
     case ("cmd_fac_scale")
        allocate (cmd_fac_scale_t :: command)
     case ("cmd_ren_scale")
        allocate (cmd_ren_scale_t :: command)
     case ("cmd_weight")
        allocate (cmd_weight_t :: command)
     case ("cmd_selection")
        allocate (cmd_selection_t :: command)
     case ("cmd_reweight")
        allocate (cmd_reweight_t :: command)
     case ("cmd_iterations")
        allocate (cmd_iterations_t :: command)
     case ("cmd_integrate")
        allocate (cmd_integrate_t :: command)
     case ("cmd_observable")
        allocate (cmd_observable_t :: command)
     case ("cmd_histogram")
        allocate (cmd_histogram_t :: command)
     case ("cmd_plot")
        allocate (cmd_plot_t :: command)
     case ("cmd_graph")
        allocate (cmd_graph_t :: command)
     case ("cmd_record")
        allocate (cmd_record_t :: command)
     case ("cmd_analysis")
        allocate (cmd_analysis_t :: command)
     case ("cmd_alt_setup")
        allocate (cmd_alt_setup_t :: command)
     case ("cmd_unstable")
        allocate (cmd_unstable_t :: command)
     case ("cmd_stable")
        allocate (cmd_stable_t :: command)
     case ("cmd_polarized")
        allocate (cmd_polarized_t :: command)
     case ("cmd_unpolarized")
        allocate (cmd_unpolarized_t :: command)
     case ("cmd_sample_format")
        allocate (cmd_sample_format_t :: command)
     case ("cmd_simulate")
        allocate (cmd_simulate_t :: command)
     case ("cmd_rescan")
        allocate (cmd_rescan_t :: command)
     case ("cmd_write_analysis")
        allocate (cmd_write_analysis_t :: command)
     case ("cmd_compile_analysis")
        allocate (cmd_compile_analysis_t :: command)
     case ("cmd_open_out")
        allocate (cmd_open_out_t :: command)
     case ("cmd_close_out")
        allocate (cmd_close_out_t :: command)
     case ("cmd_printf")
        allocate (cmd_printf_t :: command)
     case ("cmd_scan")
        allocate (cmd_scan_t :: command)
     case ("cmd_if")
        allocate (cmd_if_t :: command)
     case ("cmd_include")
        allocate (cmd_include_t :: command)
     case ("cmd_export")
        allocate (cmd_export_t :: command)
     case ("cmd_quit")
        allocate (cmd_quit_t :: command)
     case default
        print *, char (parse_node_get_rule_key (pn))
        call msg_bug ("Command not implemented")
     end select
     command%pn => pn
   end subroutine dispatch_command
 
 @ %def dispatch_command
 @ Output.  We allow for indentation so we can display a command tree.
 <<Commands: command: TBP>>=
   procedure (command_write), deferred :: write
 <<Commands: interfaces>>=
   abstract interface
      subroutine command_write (cmd, unit, indent)
        import
        class(command_t), intent(in) :: cmd
        integer, intent(in), optional :: unit, indent
      end subroutine command_write
   end interface
 
 @ %def command_write
 @ Compile a command.  The command type is already fixed, so this is a
 deferred type-bound procedure.
 <<Commands: command: TBP>>=
   procedure (command_compile), deferred :: compile
 <<Commands: interfaces>>=
   abstract interface
      subroutine command_compile (cmd, global)
        import
        class(command_t), intent(inout) :: cmd
        type(rt_data_t), intent(inout), target :: global
      end subroutine command_compile
   end interface
 
 @ %def command_compile
 @ Execute a command.  This will use and/or modify the runtime data
 set.  If the [[quit]] flag is set, the caller should terminate command
 execution.
 <<Commands: command: TBP>>=
   procedure (command_execute), deferred :: execute
 <<Commands: interfaces>>=
   abstract interface
      subroutine command_execute (cmd, global)
        import
        class(command_t), intent(inout) :: cmd
        type(rt_data_t), intent(inout), target :: global
      end subroutine command_execute
   end interface
 
 @ %def command_execute
 @
 \subsection{Options}
 The [[options]] command list is allocated, initialized, and executed, if the
 command is associated with an option text in curly braces.  If present, a
 separate local runtime data set [[local]] will be allocated and initialized;
 otherwise, [[local]] becomes a pointer to the global dataset.
 
 For output, we indent the options list.
 <<Commands: command: TBP>>=
   procedure :: write_options => command_write_options
 <<Commands: procedures>>=
   recursive subroutine command_write_options (cmd, unit, indent)
     class(command_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: ind
     ind = 1;  if (present (indent))  ind = indent + 1
     if (associated (cmd%options))  call cmd%options%write (unit, ind)
   end subroutine command_write_options
 
 @ %def command_write_options
 @ Compile the options list, if any.  This implies initialization of the local
 environment.  Should be done once the [[pn_opt]] node has been assigned (if
 applicable), but before the actual command compilation.
 <<Commands: command: TBP>>=
   procedure :: compile_options => command_compile_options
 <<Commands: procedures>>=
   recursive subroutine command_compile_options (cmd, global)
     class(command_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     if (associated (cmd%pn_opt)) then
        allocate (cmd%local)
        call cmd%local%local_init (global)
        call global%copy_globals (cmd%local)
        allocate (cmd%options)
        call cmd%options%compile (cmd%pn_opt, cmd%local)
        call global%restore_globals (cmd%local)
        call cmd%local%deactivate ()
     else
        cmd%local => global
     end if
   end subroutine command_compile_options
 
 @ %def command_compile_options
 @ Execute options.  First prepare the local environment, then execute the
 command list.
 <<Commands: command: TBP>>=
   procedure :: execute_options => cmd_execute_options
 <<Commands: procedures>>=
   recursive subroutine cmd_execute_options (cmd, global)
     class(command_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     if (associated (cmd%options)) then
        call cmd%local%activate ()
        call cmd%options%execute (cmd%local)
     end if
   end subroutine cmd_execute_options
 
 @ %def cmd_execute_options
 @ This must be called after the parent command has been executed, to undo
 temporary modifications to the environment.  Note that some modifications to
 [[global]] can become permanent.
 <<Commands: command: TBP>>=
   procedure :: reset_options => cmd_reset_options
 <<Commands: procedures>>=
   subroutine cmd_reset_options (cmd, global)
     class(command_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     if (associated (cmd%options)) then
        call cmd%local%deactivate (global)
     end if
   end subroutine cmd_reset_options
 
 @ %def cmd_reset_options
 @
 \subsection{Specific command types}
 \subsubsection{Model configuration}
 The command declares a model, looks for the specified file and loads
 it.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_model_t
      private
      type(string_t) :: name
      type(string_t) :: scheme
      logical :: ufo_model = .false.
      logical :: ufo_path_set = .false.
      type(string_t) :: ufo_path
    contains
    <<Commands: cmd model: TBP>>
   end type cmd_model_t
 
 @ %def cmd_model_t
 @ Output
 <<Commands: cmd model: TBP>>=
   procedure :: write => cmd_model_write
 <<Commands: procedures>>=
   subroutine cmd_model_write (cmd, unit, indent)
     class(cmd_model_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,1x,'""',A,'""')", advance="no")  "model =", char (cmd%name)
     if (cmd%ufo_model) then
        if (cmd%ufo_path_set) then
           write (u, "(1x,A,A,A)")  "(ufo (", char (cmd%ufo_path), "))"
        else
           write (u, "(1x,A)")  "(ufo)"
        end if
     else if (cmd%scheme /= "") then
        write (u, "(1x,'(',A,')')")  char (cmd%scheme)
     else
        write (u, *)
     end if
   end subroutine cmd_model_write
 
 @ %def cmd_model_write
 @ Compile.  Get the model name and read the model from file, so it is
 readily available when the command list is executed.  If the model has a
 scheme argument, take this into account.
 
 Assign the model pointer in the [[global]] record, so it can be used for
 (read-only) variable lookup while compiling further commands.
 <<Commands: cmd model: TBP>>=
   procedure :: compile => cmd_model_compile
 <<Commands: procedures>>=
   subroutine cmd_model_compile (cmd, global)
     class(cmd_model_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_name, pn_arg, pn_scheme
     type(parse_node_t), pointer :: pn_ufo_arg, pn_path
     type(model_t), pointer :: model
     type(string_t) :: scheme
     pn_name => cmd%pn%get_sub_ptr (3)
     pn_arg => pn_name%get_next_ptr ()
     if (associated (pn_arg)) then
        pn_scheme => pn_arg%get_sub_ptr ()
     else
        pn_scheme => null ()
     end if
     cmd%name = pn_name%get_string ()
     if (associated (pn_scheme)) then
        select case (char (pn_scheme%get_rule_key ()))
        case ("ufo_spec")
           cmd%ufo_model = .true.
           pn_ufo_arg => pn_scheme%get_sub_ptr (2)
           if (associated (pn_ufo_arg)) then
              pn_path => pn_ufo_arg%get_sub_ptr ()
              cmd%ufo_path_set = .true.
              cmd%ufo_path = pn_path%get_string ()
           end if
        case default
           scheme = pn_scheme%get_string ()
     select case (char (lower_case (scheme)))
     case ("ufo");  cmd%ufo_model = .true.
           case default;  cmd%scheme = scheme
           end select
        end select
        if (cmd%ufo_model) then
           if (cmd%ufo_path_set) then
              call preload_ufo_model (model, cmd%name, cmd%ufo_path)
           else
              call preload_ufo_model (model, cmd%name)
           end if
        else
           call preload_model (model, cmd%name, cmd%scheme)
        end if
     else
        cmd%scheme = ""
        call preload_model (model, cmd%name)
     end if
     global%model => model
     if (associated (global%model)) then
        call global%model%link_var_list (global%var_list)
     end if
   contains
     subroutine preload_model (model, name, scheme)
       type(model_t), pointer, intent(out) :: model
       type(string_t), intent(in) :: name
       type(string_t), intent(in), optional :: scheme
       model => null ()
       if (associated (global%model)) then
          if (global%model%matches (name, scheme)) then
             model => global%model
          end if
       end if
       if (.not. associated (model)) then
          if (global%model_list%model_exists (name, scheme)) then
             model => global%model_list%get_model_ptr (name, scheme)
          else
             call global%read_model (name, model, scheme)
          end if
       end if
     end subroutine preload_model
     subroutine preload_ufo_model (model, name, ufo_path)
       type(model_t), pointer, intent(out) :: model
       type(string_t), intent(in) :: name
       type(string_t), intent(in), optional :: ufo_path
       model => null ()
       if (associated (global%model)) then
          if (global%model%matches (name, ufo=.true., ufo_path=ufo_path)) then
             model => global%model
          end if
       end if
       if (.not. associated (model)) then
          if (global%model_list%model_exists (name, &
               ufo=.true., ufo_path=ufo_path)) then
             model => global%model_list%get_model_ptr (name, &
                  ufo=.true., ufo_path=ufo_path)
          else
             call global%read_ufo_model (name, model, ufo_path=ufo_path)
          end if
       end if
     end subroutine preload_ufo_model
   end subroutine cmd_model_compile
 
 @ %def cmd_model_compile
 @ Execute: Insert a pointer into the global data record and reassign
 the variable list.
 <<Commands: cmd model: TBP>>=
   procedure :: execute => cmd_model_execute
 <<Commands: procedures>>=
   subroutine cmd_model_execute (cmd, global)
     class(cmd_model_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     if (cmd%ufo_model) then
        if (cmd%ufo_path_set) then
           call global%select_model (cmd%name, ufo=.true., ufo_path=cmd%ufo_path)
        else
           call global%select_model (cmd%name, ufo=.true.)
        end if
     else if (cmd%scheme /= "") then
        call global%select_model (cmd%name, cmd%scheme)
     else
        call global%select_model (cmd%name)
     end if
     if (.not. associated (global%model)) &
          call msg_fatal ("Switching to model '" &
          // char (cmd%name) // "': model not found")
   end subroutine cmd_model_execute
 
 @ %def cmd_model_execute
 @
 \subsubsection{Library configuration}
 We configure a process library that should hold the subsequently
 defined processes.  If the referenced library exists already, just
 make it the currently active one.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_library_t
      private
      type(string_t) :: name
    contains
    <<Commands: cmd library: TBP>>
   end type cmd_library_t
 
 @ %def cmd_library_t
 @ Output.
 <<Commands: cmd library: TBP>>=
   procedure :: write => cmd_library_write
 <<Commands: procedures>>=
   subroutine cmd_library_write (cmd, unit, indent)
     class(cmd_library_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit)
     call write_indent (u, indent)
     write (u, "(1x,A,1x,'""',A,'""')")  "library =", char (cmd%name)
   end subroutine cmd_library_write
 
 @ %def cmd_library_write
 @ Compile.  Get the library name.
 <<Commands: cmd library: TBP>>=
   procedure :: compile => cmd_library_compile
 <<Commands: procedures>>=
   subroutine cmd_library_compile (cmd, global)
     class(cmd_library_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_name
     pn_name => parse_node_get_sub_ptr (cmd%pn, 3)
     cmd%name = parse_node_get_string (pn_name)
   end subroutine cmd_library_compile
 
 @ %def cmd_library_compile
 @ Execute: Initialize a new library and push it on the library stack
 (if it does not yet exist).   Insert a pointer to the library into the
 global data record.  Then, try to load the library unless the
 [[rebuild]] flag is set.
 <<Commands: cmd library: TBP>>=
   procedure :: execute => cmd_library_execute
 <<Commands: procedures>>=
   subroutine cmd_library_execute (cmd, global)
     class(cmd_library_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     logical :: rebuild_library
     lib => global%prclib_stack%get_library_ptr (cmd%name)
     rebuild_library = &
          global%var_list%get_lval (var_str ("?rebuild_library"))
     if (.not. (associated (lib))) then
        allocate (lib_entry)
        call lib_entry%init (cmd%name)
        lib => lib_entry%process_library_t
        call global%add_prclib (lib_entry)
     else
        call global%update_prclib (lib)
     end if
     if (associated (lib) .and. .not. rebuild_library) then
        call lib%update_status (global%os_data)
     end if
   end subroutine cmd_library_execute
 
 @ %def cmd_library_execute
 @
 \subsubsection{Process configuration}
 We define a process-configuration command as a specific type.  The
 incoming and outgoing particles are given evaluation-trees which we
 transform to PDG-code arrays.  For transferring to \oMega, they are
 reconverted to strings.
 
 For the incoming particles, we store parse nodes individually.  We do
 not yet resolve the outgoing state, so we store just a single parse
 node.
 
 This also includes the choice of method for the corresponding process:
 [[omega]] for \oMega\ matrix elements as Fortran code, [[ovm]] for
 \oMega\ matrix elements as a bytecode virtual machine, [[test]] for
 special processes, [[unit_test]] for internal test matrix elements
 generated by \whizard, [[template]] and [[template_unity]] for test
 matrix elements generated by \whizard\ as Fortran code similar to the
 \oMega\ code. If the one-loop program (OLP) \gosam\ is linked, also
 matrix elements from there (at leading and next-to-leading order) can
 be generated via [[gosam]].
 <<Commands: types>>=
   type, extends (command_t) :: cmd_process_t
      private
      type(string_t) :: id
      integer :: n_in  = 0
      type(parse_node_p), dimension(:), allocatable :: pn_pdg_in
      type(parse_node_t), pointer :: pn_out => null ()
    contains
    <<Commands: cmd process: TBP>>
   end type cmd_process_t
 
 @ %def cmd_process_t
 @ Output.  The particle expressions are not resolved, so we just list the
 number of incoming particles.
 <<Commands: cmd process: TBP>>=
   procedure :: write => cmd_process_write
 <<Commands: procedures>>=
   subroutine cmd_process_write (cmd, unit, indent)
     class(cmd_process_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,A,A,I0,A)")  "process: ", char (cmd%id), " (", &
          size (cmd%pn_pdg_in), " -> X)"
     call cmd%write_options (u, indent)
   end subroutine cmd_process_write
 
 @ %def cmd_process_write
 @ Compile.  Find and assign the parse nodes.
 <<Commands: cmd process: TBP>>=
   procedure :: compile => cmd_process_compile
 <<Commands: procedures>>=
   subroutine cmd_process_compile (cmd, global)
     class(cmd_process_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_id, pn_in, pn_codes
     integer :: i
     pn_id => parse_node_get_sub_ptr (cmd%pn, 2)
     pn_in  => parse_node_get_next_ptr (pn_id, 2)
     cmd%pn_out => parse_node_get_next_ptr (pn_in, 2)
     cmd%pn_opt => parse_node_get_next_ptr (cmd%pn_out)
     call cmd%compile_options (global)
     cmd%id = parse_node_get_string (pn_id)
     cmd%n_in  = parse_node_get_n_sub (pn_in)
     pn_codes => parse_node_get_sub_ptr (pn_in)
     allocate (cmd%pn_pdg_in (cmd%n_in))
     do i = 1, cmd%n_in
        cmd%pn_pdg_in(i)%ptr => pn_codes
        pn_codes => parse_node_get_next_ptr (pn_codes)
     end do
   end subroutine cmd_process_compile
 
 @ %def cmd_process_compile
 @ Command execution.  Evaluate the subevents, transform PDG codes
 into strings, and add the current process configuration to the
 process library.
 
 The initial state will be unique (one or two particles).  For the final state,
 we allow for expressions.  The expressions will be expanded until we have a
 sum of final states.  Each distinct final state will get its own process
 component.
 
 To identify equivalent final states, we transform the final state into
 an array of PDG codes, which we sort and compare.  If a particle entry
 is actually a PDG array, only the first entry in the array is used for
 the comparison. The user should make sure that there is no overlap
 between different particles or arrays which would make the expansion
 ambiguous.
 
 There are two possibilities that a process contains more than one
 component: by an explicit component statement by the user for
 inclusive processes, or by having one process at NLO level. The first
 option is determined in the routine [[scan_components]], and
 determines [[n_components]].
 <<Commands: cmd process: TBP>>=
   procedure :: execute => cmd_process_execute
 <<Commands: procedures>>=
   subroutine cmd_process_execute (cmd, global)
     class(cmd_process_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(pdg_array_t) :: pdg_in, pdg_out
     type(pdg_array_t), dimension(:), allocatable :: pdg_out_tab
     type(string_t), dimension(:), allocatable :: prt_in
     type(string_t) :: prt_out, prt_out1
     type(process_configuration_t) :: prc_config
     type(prt_expr_t) :: prt_expr_out
     type(prt_spec_t), dimension(:), allocatable :: prt_spec_in
     type(prt_spec_t), dimension(:), allocatable :: prt_spec_out
     type(var_list_t), pointer :: var_list
     integer, dimension(:), allocatable :: pdg
     integer, dimension(:), allocatable :: i_term
     integer, dimension(:), allocatable :: nlo_comp
     integer :: i, j, n_in, n_out, n_terms, n_components
     logical :: nlo_fixed_order
     logical :: qcd_corr, qed_corr
     type(string_t), dimension(:), allocatable :: prt_in_nlo, prt_out_nlo
     type(radiation_generator_t) :: radiation_generator
     type(pdg_list_t) :: pl_in, pl_out, pl_excluded_gauge_splittings
     type(string_t) :: method, born_me_method, loop_me_method, &
          correlation_me_method, real_tree_me_method, dglap_me_method
     integer, dimension(:), allocatable :: i_list
     logical :: use_real_finite
     logical :: gks_active
     logical :: initial_state_colored
     integer :: comp_mult
     integer :: gks_multiplicity
     integer :: n_components_init
     integer :: alpha_power, alphas_power
     logical :: requires_soft_mismatch, requires_dglap_remnants
     if (debug_on) call msg_debug (D_CORE, "cmd_process_execute")
     var_list => cmd%local%get_var_list_ptr ()
 
     n_in = size (cmd%pn_pdg_in)
     allocate (prt_in (n_in), prt_spec_in (n_in))
     do i = 1, n_in
        pdg_in = &
             eval_pdg_array (cmd%pn_pdg_in(i)%ptr, var_list)
        prt_in(i) = make_flavor_string (pdg_in, cmd%local%model)
        prt_spec_in(i) = new_prt_spec (prt_in(i))
     end do
     call compile_prt_expr &
          (prt_expr_out, cmd%pn_out, var_list, cmd%local%model)
     call prt_expr_out%expand ()
     call scan_components ()
     allocate (nlo_comp (n_components))
 
     nlo_fixed_order = cmd%local%nlo_fixed_order
     gks_multiplicity = var_list%get_ival (var_str ('gks_multiplicity'))
     gks_active = gks_multiplicity > 2
     call check_for_nlo_corrections ()
 
     method = var_list%get_sval (var_str ("$method"))
     born_me_method = var_list%get_sval (var_str ("$born_me_method"))
     if (born_me_method == var_str (""))  born_me_method = method
     use_real_finite = var_list%get_lval (var_str ('?nlo_use_real_partition'))
     if (nlo_fixed_order) then
        real_tree_me_method = &
             var_list%get_sval (var_str ("$real_tree_me_method"))
        if (real_tree_me_method == var_str ("")) &
             real_tree_me_method = method
        loop_me_method = var_list%get_sval (var_str ("$loop_me_method"))
        if (loop_me_method == var_str ("")) &
             loop_me_method = method
        correlation_me_method = &
             var_list%get_sval (var_str ("$correlation_me_method"))
        if (correlation_me_method == var_str ("")) &
             correlation_me_method = method
        dglap_me_method = var_list%get_sval (var_str ("$dglap_me_method"))
        if (dglap_me_method == var_str ("")) &
             dglap_me_method = method
        call check_nlo_options (cmd%local)
     end if
 
     call determine_needed_components ()
     call prc_config%init (cmd%id, n_in, n_components_init, &
          cmd%local%model, cmd%local%var_list, &
          nlo_process = nlo_fixed_order)
 
     alpha_power = var_list%get_ival (var_str ("alpha_power"))
     alphas_power = var_list%get_ival (var_str ("alphas_power"))
     call prc_config%set_coupling_powers (alpha_power, alphas_power)
 
     call setup_components ()
     call prc_config%record (cmd%local)
 
   contains
 
   <<Commands: cmd process execute procedures>>
 
   end subroutine cmd_process_execute
 
 @ %def cmd_process_execute
 @
 <<Commands: cmd process execute procedures>>=
   elemental function is_threshold (method)
     logical :: is_threshold
     type(string_t), intent(in) :: method
     is_threshold = method == var_str ("threshold")
   end function is_threshold
 
   subroutine check_threshold_consistency ()
     if (nlo_fixed_order .and. is_threshold (born_me_method)) then
        if (.not. (is_threshold (real_tree_me_method) .and. is_threshold (loop_me_method) &
             .and. is_threshold (correlation_me_method))) then
             print *, 'born: ', char (born_me_method)
             print *, 'real: ', char (real_tree_me_method)
             print *, 'loop: ', char (loop_me_method)
             print *, 'correlation: ', char (correlation_me_method)
             call msg_fatal ("Inconsistent methods: All components need to be threshold")
        end if
     end if
   end subroutine check_threshold_consistency
 
 @ %def check_threshold_consistency
 <<Commands: cmd process execute procedures>>=
   subroutine check_for_nlo_corrections ()
     type(string_t) :: nlo_correction_type
     type(pdg_array_t), dimension(:), allocatable :: pdg
     if (nlo_fixed_order .or. gks_active) then
        nlo_correction_type = &
             var_list%get_sval (var_str ('$nlo_correction_type'))
        select case (char(nlo_correction_type))
        case ("QCD")
           qcd_corr = .true.; qed_corr = .false.
        case ("EW")
           qcd_corr = .false.; qed_corr = .true.
        case ("Full")
           qcd_corr =.true.; qed_corr = .true.
        case default
           call msg_fatal ("Invalid NLO correction type! " // &
                "Valid inputs are: QCD, EW, Full (default: QCD)")
        end select
        call check_for_excluded_gauge_boson_splitting_partners ()
        call setup_radiation_generator ()
     end if
     if (nlo_fixed_order) then
        call radiation_generator%find_splittings ()
        if (debug2_active (D_CORE)) then
           print *, ''
           print *, 'Found (pdg) splittings: '
           do i = 1, radiation_generator%if_table%get_length ()
              call radiation_generator%if_table%get_pdg_out (i, pdg)
              call pdg_array_write_set (pdg)
              print *, '----------------'
           end do
        end if
 
        nlo_fixed_order = radiation_generator%contains_emissions ()
        if (.not. nlo_fixed_order) call msg_warning &
             (arr = [var_str ("No NLO corrections found for process ") // &
             cmd%id // var_str("."), var_str ("Proceed with usual " // &
             "leading-order integration and simulation")])
     end if
   end subroutine check_for_nlo_corrections
 
 @ %def check_for_nlo_corrections
 @
 <<Commands: cmd process execute procedures>>=
   subroutine check_for_excluded_gauge_boson_splitting_partners ()
     type(string_t) :: str_excluded_partners
     type(string_t), dimension(:), allocatable :: excluded_partners
     type(pdg_list_t) :: pl_tmp, pl_anti
     integer :: i, n_anti
     str_excluded_partners = var_list%get_sval &
          (var_str ("$exclude_gauge_splittings"))
     if (str_excluded_partners == "") then
        return
     else
        call split_string (str_excluded_partners, &
             var_str (":"), excluded_partners)
        call pl_tmp%init (size (excluded_partners))
        do i = 1, size (excluded_partners)
           call pl_tmp%set (i, &
                cmd%local%model%get_pdg (excluded_partners(i), .true.))
        end do
        call pl_tmp%create_antiparticles (pl_anti, n_anti)
        call pl_excluded_gauge_splittings%init (pl_tmp%get_size () + n_anti)
        do i = 1, pl_tmp%get_size ()
           call pl_excluded_gauge_splittings%set (i, pl_tmp%get(i))
        end do
        do i = 1, n_anti
           j = i + pl_tmp%get_size ()
           call pl_excluded_gauge_splittings%set (j, pl_anti%get(i))
        end do
     end if
   end subroutine check_for_excluded_gauge_boson_splitting_partners
 
 @ %def check_for_excluded_gauge_boson_splitting_partners
 @
 <<Commands: cmd process execute procedures>>=
   subroutine determine_needed_components ()
     type(string_t) :: fks_method
     comp_mult = 1
     if (nlo_fixed_order) then
        fks_method = var_list%get_sval (var_str ('$fks_mapping_type'))
        call check_threshold_consistency ()
        requires_soft_mismatch = fks_method == var_str ('resonances')
        comp_mult = needed_extra_components (requires_dglap_remnants, &
             use_real_finite, requires_soft_mismatch)
        allocate (i_list (comp_mult))
     else if (gks_active) then
        call radiation_generator%generate_multiple &
             (gks_multiplicity, cmd%local%model)
        comp_mult = radiation_generator%get_n_gks_states () + 1
     end if
     n_components_init = n_components * comp_mult
   end subroutine determine_needed_components
 
 @ %def determine_needed_components
 @
 <<Commands: cmd process execute procedures>>=
   subroutine setup_radiation_generator ()
     call split_prt (prt_spec_in, n_in, pl_in)
     call split_prt (prt_spec_out, n_out, pl_out)
     call radiation_generator%init (pl_in, pl_out, &
          pl_excluded_gauge_splittings, qcd = qcd_corr, qed = qed_corr)
     call radiation_generator%set_n (n_in, n_out, 0)
     initial_state_colored = pdg_in%has_colored_particles ()
     if ((n_in == 2 .and. initial_state_colored) .or. qed_corr) then
         requires_dglap_remnants = n_in == 2 .and. initial_state_colored
         call radiation_generator%set_initial_state_emissions ()
     else
        requires_dglap_remnants = .false.
     end if
     call radiation_generator%set_constraints (.false., .false., .true., .true.)
     call radiation_generator%setup_if_table (cmd%local%model)
   end subroutine setup_radiation_generator
 
 @ %def setup_radiation_generator
 @
 <<Commands: cmd process execute procedures>>=
   subroutine scan_components ()
     n_terms = prt_expr_out%get_n_terms ()
     allocate (pdg_out_tab (n_terms))
     allocate (i_term (n_terms), source = 0)
     n_components = 0
     SCAN: do i = 1, n_terms
        if (allocated (pdg))  deallocate (pdg)
        call prt_expr_out%term_to_array (prt_spec_out, i)
        n_out = size (prt_spec_out)
        allocate (pdg (n_out))
        do j = 1, n_out
           prt_out = prt_spec_out(j)%to_string ()
           call split (prt_out, prt_out1, ":")
           pdg(j) = cmd%local%model%get_pdg (prt_out1)
        end do
        pdg_out = sort (pdg)
        do j = 1, n_components
           if (pdg_out == pdg_out_tab(j))  cycle SCAN
        end do
        n_components = n_components + 1
        i_term(n_components) = i
        pdg_out_tab(n_components) = pdg_out
     end do SCAN
   end subroutine scan_components
 
 @
 <<Commands: cmd process execute procedures>>=
   subroutine split_prt (prt, n_out, pl)
     type(prt_spec_t), intent(in), dimension(:), allocatable :: prt
     integer, intent(in) :: n_out
     type(pdg_list_t), intent(out) :: pl
     type(pdg_array_t) :: pdg
     type(string_t) :: prt_string, prt_tmp
     integer, parameter :: max_particle_number = 25
     integer, dimension(max_particle_number) :: i_particle
     integer :: i, j, n
     i_particle = 0
     call pl%init (n_out)
     do i = 1, n_out
        n = 1
        prt_string = prt(i)%to_string ()
        do
          call split (prt_string, prt_tmp, ":")
          if (prt_tmp /= "") then
            i_particle(n) = cmd%local%model%get_pdg (prt_tmp)
            n = n + 1
          else
            exit
          end if
        end do
        call pdg_array_init (pdg, n - 1)
        do j = 1, n - 1
          call pdg%set (j, i_particle(j))
        end do
        call pl%set (i, pdg)
        call pdg_array_delete (pdg)
     end do
   end subroutine split_prt
 
 @ %def split_prt
 @
 <<Commands: cmd process execute procedures>>=
   subroutine setup_components()
     integer :: k, i_comp, add_index
     i_comp = 0
     add_index = 0
     if (debug_on) call msg_debug (D_CORE, "setup_components")
     do i = 1, n_components
        call prt_expr_out%term_to_array (prt_spec_out, i_term(i))
        if (nlo_fixed_order) then
           associate (selected_nlo_parts => cmd%local%selected_nlo_parts)
              if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
                   i_comp + 1)
              call prc_config%setup_component (i_comp + 1, &
                   prt_spec_in, prt_spec_out, &
                   cmd%local%model, var_list, BORN, &
                   can_be_integrated = selected_nlo_parts (BORN))
              call radiation_generator%generate_real_particle_strings &
                   (prt_in_nlo, prt_out_nlo)
              if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
                   i_comp + 2)
              call prc_config%setup_component (i_comp + 2, &
                   new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), &
                   cmd%local%model, var_list, NLO_REAL, &
                   can_be_integrated = selected_nlo_parts (NLO_REAL))
              if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
                   i_comp + 3)
              call prc_config%setup_component (i_comp + 3, &
                   prt_spec_in, prt_spec_out, &
                   cmd%local%model, var_list, NLO_VIRTUAL, &
                   can_be_integrated = selected_nlo_parts (NLO_VIRTUAL))
              if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
                   i_comp + 4)
              call prc_config%setup_component (i_comp + 4, &
                   prt_spec_in, prt_spec_out, &
                   cmd%local%model, var_list, NLO_SUBTRACTION, &
                   can_be_integrated = selected_nlo_parts (NLO_SUBTRACTION))
              do k = 1, 4
                 i_list(k) = i_comp + k
              end do
              if (requires_dglap_remnants) then
                 if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
                      i_comp + 5)
                 call prc_config%setup_component (i_comp + 5, &
                      prt_spec_in, prt_spec_out, &
                      cmd%local%model, var_list, NLO_DGLAP, &
                      can_be_integrated = selected_nlo_parts (NLO_DGLAP))
                 i_list(5) = i_comp + 5
                 add_index = add_index + 1
              end if
              if (use_real_finite) then
                 if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
                      i_comp + 5 + add_index)
                 call prc_config%setup_component (i_comp + 5 + add_index, &
                      new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), &
                      cmd%local%model, var_list, NLO_REAL, &
                      can_be_integrated = selected_nlo_parts (NLO_REAL))
                 i_list(5 + add_index) = i_comp + 5 + add_index
                 add_index = add_index + 1
              end if
              if (requires_soft_mismatch) then
                 if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
                      i_comp + 5 + add_index)
                 call prc_config%setup_component (i_comp + 5 + add_index, &
                    prt_spec_in, prt_spec_out, &
                    cmd%local%model, var_list, NLO_MISMATCH, &
                    can_be_integrated = selected_nlo_parts (NLO_MISMATCH))
                 i_list(5 + add_index) = i_comp + 5 + add_index
              end if
              call prc_config%set_component_associations (i_list, &
                   requires_dglap_remnants, use_real_finite, &
                   requires_soft_mismatch)
           end associate
        else if (gks_active) then
           call prc_config%setup_component (i_comp + 1, prt_spec_in, &
                prt_spec_out, cmd%local%model, var_list, BORN, &
                can_be_integrated = .true.)
           call radiation_generator%reset_queue ()
           do j = 1, comp_mult
              prt_out_nlo =  radiation_generator%get_next_state ()
              call prc_config%setup_component (i_comp + 1 + j, &
                 new_prt_spec (prt_in), new_prt_spec (prt_out_nlo), &
                 cmd%local%model, var_list, GKS, can_be_integrated = .false.)
           end do
        else
           call prc_config%setup_component (i, &
                prt_spec_in, prt_spec_out, &
                cmd%local%model, var_list, can_be_integrated = .true.)
        end if
        i_comp = i_comp + comp_mult
     end do
   end subroutine setup_components
 
 @
 @ These three functions should be bundled with the logicals they depend
 on into an object (the pcm?).
 <<Commands: procedures>>=
   subroutine check_nlo_options (local)
     type(rt_data_t), intent(in) :: local
     type(var_list_t), pointer :: var_list => null ()
     real :: mult_real, mult_virt, mult_dglap
     logical :: nlo, combined, powheg
     logical :: case_lo_but_any_other
     logical :: case_nlo_powheg_but_not_combined
     logical :: vamp_equivalences_enabled
     logical :: fixed_order_nlo_events
     var_list => local%get_var_list_ptr ()
     nlo = local%nlo_fixed_order
     combined = var_list%get_lval (var_str ('?combined_nlo_integration'))
     powheg = var_list%get_lval (var_str ('?powheg_matching'))
     case_lo_but_any_other = .not. nlo .and. any ([combined, powheg])
     case_nlo_powheg_but_not_combined = &
          nlo .and. powheg .and. .not. combined
     if (case_lo_but_any_other) then
        call msg_fatal ("Option mismatch: Leading order process is selected &
             &but either powheg_matching or combined_nlo_integration &
             &is set to true.")
     else if (case_nlo_powheg_but_not_combined) then
        call msg_fatal ("POWHEG requires the 'combined_nlo_integration'-option &
             &to be set to true.")
     end if
     fixed_order_nlo_events = &
          var_list%get_lval (var_str ('?fixed_order_nlo_events'))
     if (fixed_order_nlo_events .and. .not. combined .and. &
          count (local%selected_nlo_parts) > 1) &
        call msg_fatal ("Option mismatch: Fixed order NLO events of multiple ", &
             [var_str ("components are requested, but ?combined_nlo_integration "), &
             var_str ("is false. You can either switch to the combined NLO "), &
             var_str ("integration mode for the full process or choose one "), &
             var_str ("individual NLO component to generate events with.")])
             associate (nlo_parts => local%selected_nlo_parts)
                ! TODO (PS-2020-03-26): This technically leaves the possibility to skip this
                ! message by deactivating the dglap component for a proton collider process.
                ! To circumvent this, the selected_nlo_parts should be refactored.
                if (combined .and. .not. (nlo_parts(BORN) &
                     .and. nlo_parts(NLO_VIRTUAL) .and. nlo_parts(NLO_REAL))) then
                  call msg_fatal ("A combined integration of anything else than", &
                       [var_str ("all NLO components together is not supported.")])
                end if
             end associate
             mult_real = local%var_list%get_rval (var_str ("mult_call_real"))
             mult_virt = local%var_list%get_rval (var_str ("mult_call_virt"))
             mult_dglap = local%var_list%get_rval (var_str ("mult_call_dglap"))
             if (combined .and. (mult_real /= one .or. mult_virt /= one .or. mult_dglap /= one)) then
                call msg_warning ("mult_call_real, mult_call_virt and mult_call_dglap", &
                [var_str (" will be ignored because of ?combined_nlo_integration = true. ")])
             end if
     vamp_equivalences_enabled = var_list%get_lval &
          (var_str ('?use_vamp_equivalences'))
     if (nlo .and. vamp_equivalences_enabled) &
          call msg_warning ("You have not disabled VAMP equivalences. ", &
               [var_str ("   Note that they are automatically switched off "), &
                var_str ("   for NLO calculations.")])
   end subroutine check_nlo_options
 
 @ %def check_nlo_options
 @ There are four components for a general NLO process, namely Born,
 real, virtual and subtraction. There will be additional components for
 DGLAP remnant, in case real contributions are split into singular and
 finite pieces, and for resonance-aware FKS subtraction for the needed
 soft mismatch component.
 <<Commands: procedures>>=
   pure function needed_extra_components (requires_dglap_remnant, &
          use_real_finite, requires_soft_mismatch) result (n)
     integer :: n
     logical, intent(in) :: requires_dglap_remnant, &
          use_real_finite, requires_soft_mismatch
     n = 4
     if (requires_dglap_remnant)  n = n + 1
     if (use_real_finite)  n = n + 1
     if (requires_soft_mismatch)  n = n + 1
   end function needed_extra_components
 
 @ %def needed_extra_components
 @ This is a method of the eval tree, but cannot be coded inside the
 [[expressions]] module since it uses the [[model]] and [[flv]] types
 which are not available there.
 <<Commands: procedures>>=
   function make_flavor_string (aval, model) result (prt)
     type(string_t) :: prt
     type(pdg_array_t), intent(in) :: aval
     type(model_t), intent(in), target :: model
     integer, dimension(:), allocatable :: pdg
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     pdg = aval
     allocate (flv (size (pdg)))
     call flv%init (pdg, model)
     if (size (pdg) /= 0) then
        prt = flv(1)%get_name ()
        do i = 2, size (flv)
           prt = prt // ":" // flv(i)%get_name ()
        end do
     else
        prt = "?"
     end if
   end function make_flavor_string
 
 @ %def make_flavor_string
 @ Create a pdg array from a particle-specification array
 <<Commands: procedures>>=
   function make_pdg_array (prt, model) result (pdg_array)
     type(prt_spec_t), intent(in), dimension(:) :: prt
     type(model_t), intent(in) :: model
     integer, dimension(:), allocatable :: aval
     type(pdg_array_t) :: pdg_array
     type(flavor_t) :: flv
     integer :: k
     allocate (aval (size (prt)))
     do k = 1, size (prt)
       call flv%init (prt(k)%to_string (), model)
       aval (k) = flv%get_pdg ()
     end do
     pdg_array = aval
   end function make_pdg_array
 
 @ %def make_pdg_array
 @ Compile a (possible nested) expression, to obtain a
 particle-specifier expression which we can process further.
 <<Commands: procedures>>=
   recursive subroutine compile_prt_expr (prt_expr, pn, var_list, model)
     type(prt_expr_t), intent(out) :: prt_expr
     type(parse_node_t), intent(in), target :: pn
     type(var_list_t), intent(in), target :: var_list
     type(model_t), intent(in), target :: model
     type(parse_node_t), pointer :: pn_entry, pn_term, pn_addition
     type(pdg_array_t) :: pdg
     type(string_t) :: prt_string
     integer :: n_entry, n_term, i
     select case (char (parse_node_get_rule_key (pn)))
     case ("prt_state_list")
        n_entry = parse_node_get_n_sub (pn)
        pn_entry => parse_node_get_sub_ptr (pn)
        if (n_entry == 1) then
           call compile_prt_expr (prt_expr, pn_entry, var_list, model)
        else
           call prt_expr%init_list (n_entry)
           select type (x => prt_expr%x)
           type is (prt_spec_list_t)
              do i = 1, n_entry
                 call compile_prt_expr (x%expr(i), pn_entry, var_list, model)
                 pn_entry => parse_node_get_next_ptr (pn_entry)
              end do
           end select
        end if
     case ("prt_state_sum")
        n_term = parse_node_get_n_sub (pn)
        pn_term => parse_node_get_sub_ptr (pn)
        pn_addition => pn_term
        if (n_term == 1) then
           call compile_prt_expr (prt_expr, pn_term, var_list, model)
        else
           call prt_expr%init_sum (n_term)
           select type (x => prt_expr%x)
           type is (prt_spec_sum_t)
              do i = 1, n_term
                 call compile_prt_expr (x%expr(i), pn_term, var_list, model)
                 pn_addition => parse_node_get_next_ptr (pn_addition)
                 if (associated (pn_addition)) &
                      pn_term => parse_node_get_sub_ptr (pn_addition, 2)
              end do
           end select
        end if
     case ("cexpr")
        pdg = eval_pdg_array (pn, var_list)
        prt_string = make_flavor_string (pdg, model)
        call prt_expr%init_spec (new_prt_spec (prt_string))
     case default
        call parse_node_write_rec (pn)
        call msg_bug ("compile prt expr: impossible syntax rule")
     end select
   end subroutine compile_prt_expr
 
 @ %def compile_prt_expr
 @
 \subsubsection{Initiating a NLO calculation}
 <<Commands: types>>=
   type, extends (command_t) :: cmd_nlo_t
     private
     integer, dimension(:), allocatable :: nlo_component
   contains
     <<Commands: cmd nlo: TBP>>
   end type cmd_nlo_t
 
 @ %def cmd_nlo_t
 @
 <<Commands: cmd nlo: TBP>>=
   procedure :: write => cmd_nlo_write
 <<Commands: procedures>>=
   subroutine cmd_nlo_write (cmd, unit, indent)
     class(cmd_nlo_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
   end subroutine cmd_nlo_write
 
 @ %def cmd_nlo_write
 @ As it is, the NLO calculation is switched on by putting {nlo} behind the process definition. This should be made nicer in the future.
 <<Commands: cmd nlo: TBP>>=
   procedure :: compile => cmd_nlo_compile
 <<Commands: procedures>>=
   subroutine cmd_nlo_compile (cmd, global)
     class(cmd_nlo_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg, pn_comp
     integer :: i, n_comp
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
     if (associated (pn_arg)) then
        n_comp = parse_node_get_n_sub (pn_arg)
        allocate (cmd%nlo_component (n_comp))
        pn_comp => parse_node_get_sub_ptr (pn_arg)
        i = 0
        do while (associated (pn_comp))
           i = i + 1
           cmd%nlo_component(i) = component_status &
                (parse_node_get_rule_key (pn_comp))
           pn_comp => parse_node_get_next_ptr (pn_comp)
        end do
     else
        allocate (cmd%nlo_component (0))
     end if
   end subroutine cmd_nlo_compile
 
 @ %def cmd_nlo_compile
 @ % TODO (PS-2020-03-26): This routine still needs to be adopted
 % to cope with more than 5 components.
 <<Commands: cmd nlo: TBP>>=
   procedure :: execute => cmd_nlo_execute
 <<Commands: procedures>>=
   subroutine cmd_nlo_execute (cmd, global)
     class(cmd_nlo_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(string_t) :: string
     integer :: n, i, j
     logical, dimension(0:5) :: selected_nlo_parts
     if (debug_on) call msg_debug (D_CORE, "cmd_nlo_execute")
     selected_nlo_parts = .false.
     if (allocated (cmd%nlo_component)) then
        n = size (cmd%nlo_component)
     else
        n = 0
     end if
     do i = 1, n
        select case (cmd%nlo_component (i))
        case (BORN, NLO_VIRTUAL, NLO_MISMATCH, NLO_DGLAP, NLO_REAL)
           selected_nlo_parts(cmd%nlo_component (i)) = .true.
        case (NLO_FULL)
           selected_nlo_parts = .true.
           selected_nlo_parts (NLO_SUBTRACTION) = .false.
        case default
           string = var_str ("")
           do j = BORN, NLO_DGLAP
              string = string // component_status (j) // ", "
           end do
           string = string // component_status (NLO_FULL)
           call msg_fatal ("Invalid NLO mode. Valid modes are: " // &
                char (string))
        end select
     end do
     global%nlo_fixed_order = any (selected_nlo_parts)
     global%selected_nlo_parts = selected_nlo_parts
     allocate (global%nlo_component (size (cmd%nlo_component)))
     global%nlo_component = cmd%nlo_component
   end subroutine cmd_nlo_execute
 
 @ %def cmd_nlo_execute
 @
 \subsubsection{Process compilation}
 <<Commands: types>>=
   type, extends (command_t) :: cmd_compile_t
      private
      type(string_t), dimension(:), allocatable :: libname
      logical :: make_executable = .false.
      type(string_t) :: exec_name
    contains
    <<Commands: cmd compile: TBP>>
   end type cmd_compile_t
 
 @ %def cmd_compile_t
 @ Output: list all libraries to be compiled.
 <<Commands: cmd compile: TBP>>=
   procedure :: write => cmd_compile_write
 <<Commands: procedures>>=
   subroutine cmd_compile_write (cmd, unit, indent)
     class(cmd_compile_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "compile ("
     if (allocated (cmd%libname)) then
        do i = 1, size (cmd%libname)
           if (i > 1)  write (u, "(A,1x)", advance="no")  ","
           write (u, "('""',A,'""')", advance="no")  char (cmd%libname(i))
        end do
     end if
     write (u, "(A)")  ")"
   end subroutine cmd_compile_write
 
 @ %def cmd_compile_write
 @ Compile the libraries specified in the argument.  If the argument is
 empty, compile all libraries which can be found in the process library stack.
 <<Commands: cmd compile: TBP>>=
   procedure :: compile => cmd_compile_compile
 <<Commands: procedures>>=
   subroutine cmd_compile_compile (cmd, global)
     class(cmd_compile_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_arg, pn_lib
     type(parse_node_t), pointer :: pn_exec_name_spec, pn_exec_name
     integer :: n_lib, i
     pn_cmd => parse_node_get_sub_ptr (cmd%pn)
     pn_clause => parse_node_get_sub_ptr (pn_cmd)
     pn_exec_name_spec => parse_node_get_sub_ptr (pn_clause, 2)
     if (associated (pn_exec_name_spec)) then
        pn_exec_name => parse_node_get_sub_ptr (pn_exec_name_spec, 2)
     else
        pn_exec_name => null ()
     end if
     pn_arg => parse_node_get_next_ptr (pn_clause)
     cmd%pn_opt => parse_node_get_next_ptr (pn_cmd)
     call cmd%compile_options (global)
     if (associated (pn_arg)) then
        n_lib = parse_node_get_n_sub (pn_arg)
     else
        n_lib = 0
     end if
     if (n_lib > 0) then
        allocate (cmd%libname (n_lib))
        pn_lib => parse_node_get_sub_ptr (pn_arg)
        do i = 1, n_lib
           cmd%libname(i) = parse_node_get_string (pn_lib)
           pn_lib => parse_node_get_next_ptr (pn_lib)
        end do
     end if
     if (associated (pn_exec_name)) then
        cmd%make_executable = .true.
        cmd%exec_name = parse_node_get_string (pn_exec_name)
     end if
   end subroutine cmd_compile_compile
 
 @ %def cmd_compile_compile
 @ Command execution.  Generate code, write driver, compile and link.
 Do this for all libraries in the list.
 
 If no library names have been given and stored while compiling this
 command, we collect all libraries from the current stack and compile
 those.
 
 As a bonus, a compiled library may be able to spawn new process
 libraries.  For instance, a processes may ask for a set of resonant
 subprocesses which go into their own library, but this can be
 determined only after the process is available as a compiled object.
 Therefore, the compilation loop is implemented as a recursive internal
 subroutine.
 
 We can compile static libraries (which actually just loads them).  However, we
 can't incorporate in a generated executable.
 <<Commands: cmd compile: TBP>>=
   procedure :: execute => cmd_compile_execute
 <<Commands: procedures>>=
   subroutine cmd_compile_execute (cmd, global)
     class(cmd_compile_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(string_t), dimension(:), allocatable :: libname, libname_static
     integer :: i, n_lib
     <<Commands: cmd compile execute: extra variables>>
     <<Commands: cmd compile execute: extra init>>
     if (allocated (cmd%libname)) then
        allocate (libname (size (cmd%libname)))
        libname = cmd%libname
     else
        call cmd%local%prclib_stack%get_names (libname)
     end if
     n_lib = size (libname)
     if (cmd%make_executable) then
        call get_prclib_static (libname_static)
        do i = 1, n_lib
           if (any (libname_static == libname(i))) then
              call msg_fatal ("Compile: can't include static library '" &
                   // char (libname(i)) // "'")
           end if
        end do
        call compile_executable (cmd%exec_name, libname, cmd%local)
     else
        call compile_libraries (libname)
        call global%update_prclib &
             (global%prclib_stack%get_library_ptr (libname(n_lib)))
     end if
     <<Commands: cmd compile execute: extra end init>>
   contains
     recursive subroutine compile_libraries (libname)
       type(string_t), dimension(:), intent(in) :: libname
       integer :: i
       type(string_t), dimension(:), allocatable :: libname_extra
       type(process_library_t), pointer :: lib_saved
       do i = 1, size (libname)
          call compile_library (libname(i), cmd%local)
          lib_saved => global%prclib
          call spawn_extra_libraries &
               (libname(i), cmd%local, global, libname_extra)
          call compile_libraries (libname_extra)
          call global%update_prclib (lib_saved)
       end do
     end subroutine compile_libraries
   end subroutine cmd_compile_execute
 
 @ %def cmd_compile_execute
 <<Commands: cmd compile execute: extra variables>>=
 <<Commands: cmd compile execute: extra init>>=
 <<Commands: cmd compile execute: extra end init>>=
 @ The parallelization leads to undefined behavior while writing simultaneously to one file.
 The master worker has to initialize single-handed the corresponding library files.
 The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag.
 <<MPI: Commands: cmd compile execute: extra variables>>=
   logical :: compile_init
   integer :: rank, n_size
 <<MPI: Commands: cmd compile execute: extra init>>=
   if (debug_on) call msg_debug (D_MPI, "cmd_compile_execute")
   compile_init = .false.
   call mpi_get_comm_id (n_size, rank)
   if (debug_on) call msg_debug (D_MPI, "n_size", rank)
   if (debug_on) call msg_debug (D_MPI, "rank", rank)
   if (rank /= 0) then
      if (debug_on) call msg_debug (D_MPI, "wait for master")
      call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
   else
      compile_init = .true.
   end if
 
   if (compile_init) then
 <<MPI: Commands: cmd compile execute: extra end init>>=
   if (rank == 0) then
      if (debug_on) call msg_debug (D_MPI, "load slaves")
      call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
   end if
 end if
 call MPI_barrier (MPI_COMM_WORLD)
 @ %def cmd_compile_execute_mpi
 @
 This is the interface to the external procedure which returns the
 names of all static libraries which are part of the executable.  (The
 default is none.)  The routine must allocate the array.
 <<Commands: public>>=
   public :: get_prclib_static
 <<Commands: interfaces>>=
   interface
      subroutine get_prclib_static (libname)
        import
        type(string_t), dimension(:), intent(inout), allocatable :: libname
      end subroutine get_prclib_static
   end interface
 
 @ %def get_prclib_static
 @
 Spawn extra libraries.  We can ask the processes within a compiled
 library, which we have available at this point, whether they need additional
 processes which should go into their own libraries.
 
 The current implementation only concerns resonant subprocesses.
 
 Note that the libraries should be created (source code), but not be
 compiled here.  This is done afterwards.
 <<Commands: procedures>>=
   subroutine spawn_extra_libraries (libname, local, global, libname_extra)
     type(string_t), intent(in) :: libname
     type(rt_data_t), intent(inout), target :: local
     type(rt_data_t), intent(inout), target :: global
     type(string_t), dimension(:), allocatable, intent(out) :: libname_extra
     type(string_t), dimension(:), allocatable :: libname_res
     allocate (libname_extra (0))
     call spawn_resonant_subprocess_libraries &
          (libname, local, global, libname_res)
     if (allocated (libname_res))  libname_extra = [libname_extra, libname_res]
   end subroutine spawn_extra_libraries
 
 @ %def spawn_extra_libraries
 @
 \subsubsection{Execute a shell command}
 The argument is a string expression.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_exec_t
      private
      type(parse_node_t), pointer :: pn_command => null ()
    contains
    <<Commands: cmd exec: TBP>>
   end type cmd_exec_t
 
 @ %def cmd_exec_t
 @ Simply tell the status.
 <<Commands: cmd exec: TBP>>=
   procedure :: write => cmd_exec_write
 <<Commands: procedures>>=
   subroutine cmd_exec_write (cmd, unit, indent)
     class(cmd_exec_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     if (associated (cmd%pn_command)) then
        write (u, "(1x,A)")  "exec: [command associated]"
     else
        write (u, "(1x,A)")  "exec: [undefined]"
     end if
   end subroutine cmd_exec_write
 
 @ %def cmd_exec_write
 @ Compile the exec command.
 <<Commands: cmd exec: TBP>>=
   procedure :: compile => cmd_exec_compile
 <<Commands: procedures>>=
   subroutine cmd_exec_compile (cmd, global)
     class(cmd_exec_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg, pn_command
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
     pn_command => parse_node_get_sub_ptr (pn_arg)
     cmd%pn_command => pn_command
   end subroutine cmd_exec_compile
 
 @ %def cmd_exec_compile
 @ Execute the specified shell command.
 <<Commands: cmd exec: TBP>>=
   procedure :: execute => cmd_exec_execute
 <<Commands: procedures>>=
   subroutine cmd_exec_execute (cmd, global)
     class(cmd_exec_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(string_t) :: command
     logical :: is_known
     integer :: status
     command = eval_string (cmd%pn_command, global%var_list, is_known=is_known)
     if (is_known) then
        if (command /= "") then
           call os_system_call (command, status, verbose=.true.)
           if (status /= 0) then
              write (msg_buffer, "(A,I0)")  "Return code = ", status
              call msg_message ()
              call msg_error ("System command returned with nonzero status code")
           end if
        end if
     end if
   end subroutine cmd_exec_execute
 
 @ %def cmd_exec_execute
 @
 \subsubsection{Variable declaration}
 A variable can have various types.  Hold the definition as an eval
 tree.
 
 There are intrinsic variables, user variables, and model variables.
 The latter are further divided in independent variables and dependent
 variables.
 
 Regarding model variables: When dealing with them, we always look at
 two variable lists in parallel.  The global (or local) variable list
 contains the user-visible values.  It includes variables that
 correspond to variables in the current model's list.  These, in turn,
 are pointers to the model's parameter list, so the model is always in
 sync, internally.  To keep the global variable list in sync with the
 model, the global variables carry the [[is_copy]] property and contain
 a separate pointer to the model variable.  (The pointer is reassigned
 whenever the model changes.)  Modifying the global variable changes
 two values simultaneously: the visible value and the model variable,
 via this extra pointer.  After each modification, we update dependent
 parameters in the model variable list and re-synchronize the global
 variable list (again, using these pointers) with the model variable
 this.  In the last step, modifications in the derived parameters
 become visible.
 
 When we integrate a process, we capture the current variable list of
 the current model in a separate model instance, which is stored in the
 process object.  Thus, the model parameters associated to this process
 at this time are preserved for the lifetime of the process object.
 
 When we generate or rescan events, we can again capture a local model
 variable list in a model instance.  This allows us to reweight event
 by event with different parameter sets simultaneously.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_var_t
      private
      type(string_t) :: name
      integer :: type = V_NONE
      type(parse_node_t), pointer :: pn_value => null ()
      logical :: is_intrinsic = .false.
      logical :: is_model_var = .false.
    contains
    <<Commands: cmd var: TBP>>
   end type cmd_var_t
 
 @ %def cmd_var_t
 @ Output.  We know name, type, and properties, but not the value.
 <<Commands: cmd var: TBP>>=
   procedure :: write => cmd_var_write
 <<Commands: procedures>>=
   subroutine cmd_var_write (cmd, unit, indent)
     class(cmd_var_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,A,A)", advance="no")  "var: ", char (cmd%name), " ("
     select case (cmd%type)
     case (V_NONE)
        write (u, "(A)", advance="no")  "[unknown]"
     case (V_LOG)
        write (u, "(A)", advance="no")  "logical"
     case (V_INT)
        write (u, "(A)", advance="no")  "int"
     case (V_REAL)
        write (u, "(A)", advance="no")  "real"
     case (V_CMPLX)
        write (u, "(A)", advance="no")  "complex"
     case (V_STR)
        write (u, "(A)", advance="no")  "string"
     case (V_PDG)
        write (u, "(A)", advance="no")  "alias"
     end select
     if (cmd%is_intrinsic) then
        write (u, "(A)", advance="no")  ", intrinsic"
     end if
     if (cmd%is_model_var) then
        write (u, "(A)", advance="no")  ", model"
     end if
     write (u, "(A)")  ")"
   end subroutine cmd_var_write
 
 @ %def cmd_var_write
 @ Compile the lhs and determine the variable name and type.  Check whether
 this variable can be created or modified as requested, and append the value to
 the variable list, if appropriate.  The value is initially undefined.
 The rhs is assigned to a pointer, to be compiled and evaluated when the
 command is executed.
 <<Commands: cmd var: TBP>>=
   procedure :: compile => cmd_var_compile
 <<Commands: procedures>>=
   subroutine cmd_var_compile (cmd, global)
     class(cmd_var_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_var, pn_name
     type(parse_node_t), pointer :: pn_result, pn_proc
     type(string_t) :: var_name
     type(var_list_t), pointer :: model_vars
     integer :: type
     logical :: new
     pn_result => null ()
     new = .false.
     select case (char (parse_node_get_rule_key (cmd%pn)))
     case ("cmd_log_decl");    type = V_LOG
        pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
        if (.not. associated (pn_var)) then   ! handle masked syntax error
           cmd%type = V_NONE; return
        end if
        pn_name => parse_node_get_sub_ptr (pn_var, 2)
        new = .true.
     case ("cmd_log");         type = V_LOG
        pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
     case ("cmd_int");         type = V_INT
        pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
        new = .true.
     case ("cmd_real");        type = V_REAL
        pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
        new = .true.
     case ("cmd_complex");       type = V_CMPLX
        pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
        new = .true.
     case ("cmd_num");         type = V_NONE
        pn_name => parse_node_get_sub_ptr (cmd%pn)
     case ("cmd_string_decl"); type = V_STR
        pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
        if (.not. associated (pn_var)) then   ! handle masked syntax error
           cmd%type = V_NONE; return
        end if
        pn_name => parse_node_get_sub_ptr (pn_var, 2)
        new = .true.
     case ("cmd_string");      type = V_STR
        pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
     case ("cmd_alias");       type = V_PDG
        pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
        new = .true.
     case ("cmd_result");      type = V_REAL
        pn_name => parse_node_get_sub_ptr (cmd%pn)
        pn_result => parse_node_get_sub_ptr (pn_name)
        pn_proc => parse_node_get_next_ptr (pn_result)
     case default
        call parse_node_mismatch &
             ("logical|int|real|complex|?|$|alias|var_name", cmd%pn)  ! $
     end select
     if (.not. associated (pn_name)) then   ! handle masked syntax error
        cmd%type = V_NONE; return
     end if
     if (.not. associated (pn_result)) then
        var_name = parse_node_get_string (pn_name)
     else
        var_name = parse_node_get_key (pn_result) &
             // "(" // parse_node_get_string (pn_proc) // ")"
     end if
     select case (type)
     case (V_LOG);  var_name = "?" // var_name
     case (V_STR);  var_name = "$" // var_name    ! $
     end select
     if (associated (global%model)) then
        model_vars => global%model%get_var_list_ptr ()
     else
        model_vars => null ()
     end if
     call var_list_check_observable (global%var_list, var_name, type)
     call var_list_check_result_var (global%var_list, var_name, type)
     call global%var_list%check_user_var (var_name, type, new)
     cmd%name = var_name
     cmd%pn_value => parse_node_get_next_ptr (pn_name, 2)
     if (global%var_list%contains (cmd%name, follow_link = .false.)) then
        ! local variable
        cmd%is_intrinsic = &
             global%var_list%is_intrinsic (cmd%name, follow_link = .false.)
        cmd%type = &
             global%var_list%get_type (cmd%name, follow_link = .false.)
     else
        if (new)  cmd%type = type
        if (global%var_list%contains (cmd%name, follow_link = .true.)) then
           ! global variable
           cmd%is_intrinsic = &
                global%var_list%is_intrinsic (cmd%name, follow_link = .true.)
           if (cmd%type == V_NONE) then
              cmd%type = &
                   global%var_list%get_type (cmd%name, follow_link = .true.)
           end if
        else if (associated (model_vars)) then  ! check model variable
           cmd%is_model_var = &
                model_vars%contains (cmd%name)
           if (cmd%type == V_NONE) then
              cmd%type = &
                   model_vars%get_type (cmd%name)
           end if
        end if
        if (cmd%type == V_NONE) then
           call msg_fatal ("Variable '" // char (cmd%name) // "' " &
                // "set without declaration")
           cmd%type = V_NONE;  return
        end if
        if (cmd%is_model_var) then
           if (new) then
              call msg_fatal ("Model variable '" // char (cmd%name) // "' " &
                   // "redeclared")
           else if (model_vars%is_locked (cmd%name)) then
              call msg_fatal ("Model variable '" // char (cmd%name) // "' " &
                   // "is locked")
           end if
        else
           select case (cmd%type)
           case (V_LOG)
              call global%var_list%append_log (cmd%name, &
                   intrinsic=cmd%is_intrinsic, user=.true.)
           case (V_INT)
              call global%var_list%append_int (cmd%name, &
                   intrinsic=cmd%is_intrinsic, user=.true.)
           case (V_REAL)
              call global%var_list%append_real (cmd%name, &
                   intrinsic=cmd%is_intrinsic, user=.true.)
           case (V_CMPLX)
              call global%var_list%append_cmplx (cmd%name, &
                   intrinsic=cmd%is_intrinsic, user=.true.)
           case (V_PDG)
              call global%var_list%append_pdg_array (cmd%name, &
                   intrinsic=cmd%is_intrinsic, user=.true.)
           case (V_STR)
              call global%var_list%append_string (cmd%name, &
                   intrinsic=cmd%is_intrinsic, user=.true.)
           end select
        end if
     end if
   end subroutine cmd_var_compile
 
 @ %def cmd_var_compile
 @ Execute.  Evaluate the definition and assign the variable value.
 If the variable is a model variable, take a snapshot of the model if necessary
 and set the variable in the local model.
 <<Commands: cmd var: TBP>>=
   procedure :: execute => cmd_var_execute
 <<Commands: procedures>>=
   subroutine cmd_var_execute (cmd, global)
     class(cmd_var_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     real(default) :: rval
     logical :: is_known, pacified
     var_list => global%get_var_list_ptr ()
     if (cmd%is_model_var) then
        pacified = var_list%get_lval (var_str ("?pacify"))
        rval = eval_real (cmd%pn_value, var_list, is_known=is_known)
        call global%model_set_real &
             (cmd%name, rval, verbose=.true., pacified=pacified)
     else if (cmd%type /= V_NONE) then
        call cmd%set_value (var_list, verbose=.true.)
     end if
   end subroutine cmd_var_execute
 
 @ %def cmd_var_execute
 @ Copy the value to the variable list, where the variable should already exist.
 <<Commands: cmd var: TBP>>=
   procedure :: set_value => cmd_var_set_value
 <<Commands: procedures>>=
   subroutine cmd_var_set_value (var, var_list, verbose, model_name)
     class(cmd_var_t), intent(inout) :: var
     type(var_list_t), intent(inout), target :: var_list
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     logical :: lval, pacified
     integer :: ival
     real(default) :: rval
     complex(default) :: cval
     type(pdg_array_t) :: aval
     type(string_t) :: sval
     logical :: is_known
     pacified = var_list%get_lval (var_str ("?pacify"))
     select case (var%type)
     case (V_LOG)
        lval = eval_log (var%pn_value, var_list, is_known=is_known)
        call var_list%set_log (var%name, &
             lval, is_known, verbose=verbose, model_name=model_name)
     case (V_INT)
        ival = eval_int (var%pn_value, var_list, is_known=is_known)
        call var_list%set_int (var%name, &
             ival, is_known, verbose=verbose, model_name=model_name)
     case (V_REAL)
        rval = eval_real (var%pn_value, var_list, is_known=is_known)
        call var_list%set_real (var%name, &
             rval, is_known, verbose=verbose, &
             model_name=model_name, pacified = pacified)
     case (V_CMPLX)
        cval = eval_cmplx (var%pn_value, var_list, is_known=is_known)
        call var_list%set_cmplx (var%name, &
             cval, is_known, verbose=verbose, &
             model_name=model_name, pacified = pacified)
     case (V_PDG)
        aval = eval_pdg_array (var%pn_value, var_list, is_known=is_known)
        call var_list%set_pdg_array (var%name, &
             aval, is_known, verbose=verbose, model_name=model_name)
     case (V_STR)
        sval = eval_string (var%pn_value, var_list, is_known=is_known)
        call var_list%set_string (var%name, &
             sval, is_known, verbose=verbose, model_name=model_name)
     end select
   end subroutine cmd_var_set_value
 
 @ %def cmd_var_set_value
 @
 \subsubsection{SLHA}
 Read a SLHA (SUSY Les Houches Accord) file to fill the appropriate
 model parameters.  We do not access the current variable record, but
 directly work on the appropriate SUSY model, which is loaded if
 necessary.
 
 We may be in read or write mode.  In the latter case, we may write
 just input parameters, or the complete spectrum, or the spectrum with
 all decays.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_slha_t
      private
      type(string_t) :: file
      logical :: write_mode = .false.
    contains
    <<Commands: cmd slha: TBP>>
   end type cmd_slha_t
 
 @ %def cmd_slha_t
 @ Output.
 <<Commands: cmd slha: TBP>>=
   procedure :: write => cmd_slha_write
 <<Commands: procedures>>=
   subroutine cmd_slha_write (cmd, unit, indent)
     class(cmd_slha_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,A)")  "slha: file name  = ", char (cmd%file)
     write (u, "(1x,A,L1)") "slha: write mode = ", cmd%write_mode
   end subroutine cmd_slha_write
 
 @ %def cmd_slha_write
 @ Compile.  Read the filename and store it.
 <<Commands: cmd slha: TBP>>=
   procedure :: compile => cmd_slha_compile
 <<Commands: procedures>>=
   subroutine cmd_slha_compile (cmd, global)
     class(cmd_slha_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_key, pn_arg, pn_file
     pn_key => parse_node_get_sub_ptr (cmd%pn)
     pn_arg => parse_node_get_next_ptr (pn_key)
     pn_file => parse_node_get_sub_ptr (pn_arg)
     call cmd%compile_options (global)
     cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
     select case (char (parse_node_get_key (pn_key)))
     case ("read_slha")
        cmd%write_mode = .false.
     case ("write_slha")
        cmd%write_mode = .true.
     case default
        call parse_node_mismatch ("read_slha|write_slha",  cmd%pn)
     end select
     cmd%file = parse_node_get_string (pn_file)
   end subroutine cmd_slha_compile
 
 @ %def cmd_slha_compile
 @ Execute.  Read or write the specified SLHA file.  Behind the scenes,
 this will first read the WHIZARD model file, then read the SLHA file
 and assign the SLHA parameters as far as determined by
 [[dispatch_slha]].  Finally, the global variables are synchronized
 with the model.  This is similar to executing [[cmd_model]].
 <<Commands: cmd slha: TBP>>=
   procedure :: execute => cmd_slha_execute
 <<Commands: procedures>>=
   subroutine cmd_slha_execute (cmd, global)
     class(cmd_slha_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     logical :: input, spectrum, decays
     if (cmd%write_mode) then
        input = .true.
        spectrum = .false.
        decays = .false.
        if (.not. associated (cmd%local%model)) then
           call msg_fatal ("SLHA: local model not associated")
           return
        end if
        call slha_write_file &
             (cmd%file, cmd%local%model, &
              input = input, spectrum = spectrum, decays = decays)
     else
        if (.not. associated (global%model)) then
           call msg_fatal ("SLHA: global model not associated")
           return
        end if
        call dispatch_slha (cmd%local%var_list, &
             input = input, spectrum = spectrum, decays = decays)
        call global%ensure_model_copy ()
        call slha_read_file &
             (cmd%file, cmd%local%os_data, global%model, &
              input = input, spectrum = spectrum, decays = decays)
     end if
   end subroutine cmd_slha_execute
 
 @ %def cmd_slha_execute
 @
 \subsubsection{Show values}
 This command shows the current values of variables or other objects,
 in a suitably condensed form.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_show_t
      private
      type(string_t), dimension(:), allocatable :: name
    contains
    <<Commands: cmd show: TBP>>
   end type cmd_show_t
 
 @ %def cmd_show_t
 @ Output: list the object names, not values.
 <<Commands: cmd show: TBP>>=
   procedure :: write => cmd_show_write
 <<Commands: procedures>>=
   subroutine cmd_show_write (cmd, unit, indent)
     class(cmd_show_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "show: "
     if (allocated (cmd%name)) then
        do i = 1, size (cmd%name)
           write (u, "(1x,A)", advance="no")  char (cmd%name(i))
        end do
        write (u, *)
     else
        write (u, "(5x,A)")  "[undefined]"
     end if
   end subroutine cmd_show_write
 
 @ %def cmd_show_write
 @ Compile.  Allocate an array which is filled with the names of the
 variables to show.
 <<Commands: cmd show: TBP>>=
   procedure :: compile => cmd_show_compile
 <<Commands: procedures>>=
   subroutine cmd_show_compile (cmd, global)
     class(cmd_show_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
     type(string_t) :: key
     integer :: i, n_args
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
     if (associated (pn_arg)) then
        select case (char (parse_node_get_rule_key (pn_arg)))
        case ("show_arg")
           cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
        case default
           cmd%pn_opt => pn_arg
           pn_arg => null ()
        end select
     end if
     call cmd%compile_options (global)
     if (associated (pn_arg)) then
        n_args = parse_node_get_n_sub (pn_arg)
        allocate (cmd%name (n_args))
        pn_var => parse_node_get_sub_ptr (pn_arg)
        i = 0
        do while (associated (pn_var))
           i = i + 1
           select case (char (parse_node_get_rule_key (pn_var)))
           case ("model", "library", "beams", "iterations", &
                 "cuts", "weight", "int", "real", "complex", &
                 "scale", "factorization_scale", "renormalization_scale", &
                 "selection", "reweight", "analysis", "pdg", &
                 "stable", "unstable", "polarized", "unpolarized", &
                 "results", "expect", "intrinsic", "string", "logical")
              cmd%name(i) = parse_node_get_key (pn_var)
           case ("result_var")
              pn_prefix => parse_node_get_sub_ptr (pn_var)
              pn_name => parse_node_get_next_ptr (pn_prefix)
              if (associated (pn_name)) then
                 cmd%name(i) = parse_node_get_key (pn_prefix) &
                      // "(" // parse_node_get_string (pn_name) // ")"
              else
                 cmd%name(i) = parse_node_get_key (pn_prefix)
              end if
           case ("log_var", "string_var", "alias_var")
              pn_prefix => parse_node_get_sub_ptr (pn_var)
              pn_name => parse_node_get_next_ptr (pn_prefix)
              key = parse_node_get_key (pn_prefix)
              if (associated (pn_name)) then
                 select case (char (parse_node_get_rule_key (pn_name)))
                 case ("var_name")
                    select case (char (key))
                    case ("?", "$")  ! $ sign
                       cmd%name(i) = key // parse_node_get_string (pn_name)
                    case ("alias")
                       cmd%name(i) = parse_node_get_string (pn_name)
                    end select
                 case default
                    call parse_node_mismatch &
                         ("var_name",  pn_name)
                 end select
              else
                 cmd%name(i) = key
              end if
           case default
              cmd%name(i) = parse_node_get_string (pn_var)
           end select
           pn_var => parse_node_get_next_ptr (pn_var)
        end do
     else
        allocate (cmd%name (0))
     end if
   end subroutine cmd_show_compile
 
 @ %def cmd_show_compile
 @ Execute.  Scan the list of objects to show.
 <<Commands: parameters>>=
   integer, parameter, public :: SHOW_BUFFER_SIZE = 4096
 <<Commands: cmd show: TBP>>=
   procedure :: execute => cmd_show_execute
 <<Commands: procedures>>=
   subroutine cmd_show_execute (cmd, global)
     class(cmd_show_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list, model_vars
     type(model_t), pointer :: model
     type(string_t) :: name
     integer :: n, pdg
     type(flavor_t) :: flv
     type(process_library_t), pointer :: prc_lib
     type(process_t), pointer :: process
     logical :: pacified
     character(SHOW_BUFFER_SIZE) :: buffer
     type(string_t) :: out_file
     integer :: i, j, u, u_log, u_out, u_ext
     u = free_unit ()
     var_list => cmd%local%var_list
     if (associated (cmd%local%model)) then
        model_vars => cmd%local%model%get_var_list_ptr ()
     else
        model_vars => null ()
     end if
     pacified = var_list%get_lval (var_str ("?pacify"))
     out_file = var_list%get_sval (var_str ("$out_file"))
     if (file_list_is_open (global%out_files, out_file, action="write")) then
        call msg_message ("show: copying output to file '" &
             // char (out_file) // "'")
        u_ext = file_list_get_unit (global%out_files, out_file)
     else
        u_ext = -1
     end if
     open (u, status = "scratch", action = "readwrite")
     if (associated (cmd%local%model)) then
        name = cmd%local%model%get_name ()
     end if
     if (size (cmd%name) == 0) then
        if (associated (model_vars)) then
           call model_vars%write (model_name = name, &
                unit = u, pacified = pacified, follow_link = .false.)
        end if
        call var_list%write (unit = u, pacified = pacified)
     else
        do i = 1, size (cmd%name)
           select case (char (cmd%name(i)))
           case ("model")
              if (associated (cmd%local%model)) then
                 call cmd%local%model%show (u)
              else
                 write (u, "(A)")  "Model: [undefined]"
              end if
           case ("library")
              if (associated (cmd%local%prclib)) then
                 call cmd%local%prclib%show (u)
              else
                 write (u, "(A)")  "Process library: [undefined]"
              end if
           case ("beams")
              call cmd%local%show_beams (u)
           case ("iterations")
              call cmd%local%it_list%write (u)
           case ("results")
              call cmd%local%process_stack%show (u, fifo=.true.)
           case ("stable")
              call cmd%local%model%show_stable (u)
           case ("polarized")
              call cmd%local%model%show_polarized (u)
           case ("unpolarized")
              call cmd%local%model%show_unpolarized (u)
           case ("unstable")
              model => cmd%local%model
              call model%show_unstable (u)
              n = model%get_n_field ()
              do j = 1, n
                 pdg = model%get_pdg (j)
                 call flv%init (pdg, model)
                 if (.not. flv%is_stable ()) &
                      call show_unstable (cmd%local, pdg, u)
                 if (flv%has_antiparticle ()) then
                    associate (anti => flv%anti ())
                      if (.not. anti%is_stable ()) &
                           call show_unstable (cmd%local, -pdg, u)
                    end associate
                 end if
              end do
           case ("cuts", "weight", "scale", &
                "factorization_scale", "renormalization_scale", &
                "selection", "reweight", "analysis")
              call cmd%local%pn%show (cmd%name(i), u)
           case ("expect")
              call expect_summary (force = .true.)
           case ("intrinsic")
              call var_list%write (intrinsic=.true., unit=u, &
                   pacified = pacified)
           case ("logical")
              if (associated (model_vars)) then
                 call model_vars%write (only_type=V_LOG, &
                      model_name = name, unit=u, pacified = pacified, &
                      follow_link=.false.)
              end if
              call var_list%write (&
                   only_type=V_LOG, unit=u, pacified = pacified)
           case ("int")
              if (associated (model_vars)) then
                 call model_vars%write (only_type=V_INT, &
                      model_name = name, unit=u, pacified = pacified, &
                      follow_link=.false.)
              end if
              call var_list%write (only_type=V_INT, &
                   unit=u, pacified = pacified)
           case ("real")
              if (associated (model_vars)) then
                 call model_vars%write (only_type=V_REAL, &
                      model_name = name, unit=u, pacified = pacified, &
                      follow_link=.false.)
              end if
              call var_list%write (only_type=V_REAL, &
                   unit=u, pacified = pacified)
           case ("complex")
              if (associated (model_vars)) then
                 call model_vars%write (only_type=V_CMPLX, &
                      model_name = name, unit=u, pacified = pacified, &
                      follow_link=.false.)
              end if
              call var_list%write (only_type=V_CMPLX, &
                   unit=u, pacified = pacified)
           case ("pdg")
              if (associated (model_vars)) then
                 call model_vars%write (only_type=V_PDG, &
                      model_name = name, unit=u, pacified = pacified, &
                      follow_link=.false.)
              end if
              call var_list%write (only_type=V_PDG, &
                   unit=u, pacified = pacified)
           case ("string")
              if (associated (model_vars)) then
                 call model_vars%write (only_type=V_STR, &
                      model_name = name, unit=u, pacified = pacified, &
                      follow_link=.false.)
              end if
              call var_list%write (only_type=V_STR, &
                   unit=u, pacified = pacified)
           case default
              if (analysis_exists (cmd%name(i))) then
                 call analysis_write (cmd%name(i), u)
              else if (cmd%local%process_stack%exists (cmd%name(i))) then
                 process => cmd%local%process_stack%get_process_ptr (cmd%name(i))
                 call process%show (u)
              else if (associated (cmd%local%prclib_stack%get_library_ptr &
                   (cmd%name(i)))) then
                 prc_lib => cmd%local%prclib_stack%get_library_ptr (cmd%name(i))
                 call prc_lib%show (u)
              else if (associated (model_vars)) then
                 if (model_vars%contains (cmd%name(i), follow_link=.false.)) then
                    call model_vars%write_var (cmd%name(i), &
                         unit = u, model_name = name, pacified = pacified)
                 else if (var_list%contains (cmd%name(i))) then
                    call var_list%write_var (cmd%name(i), &
                         unit = u, pacified = pacified)
                 else
                    call msg_error ("show: object '" // char (cmd%name(i)) &
                         // "' not found")
                 end if
              else if (var_list%contains (cmd%name(i))) then
                 call var_list%write_var (cmd%name(i), &
                      unit = u, pacified = pacified)
              else
                 call msg_error ("show: object '" // char (cmd%name(i)) &
                      // "' not found")
              end if
           end select
        end do
     end if
     rewind (u)
     u_log = logfile_unit ()
     u_out = given_output_unit ()
     do
        read (u, "(A)", end = 1)  buffer
        if (u_log > 0)  write (u_log, "(A)")  trim (buffer)
        if (u_out > 0)  write (u_out, "(A)")  trim (buffer)
        if (u_ext > 0)  write (u_ext, "(A)")  trim (buffer)
     end do
 1   close (u)
     if (u_log > 0)  flush (u_log)
     if (u_out > 0)  flush (u_out)
     if (u_ext > 0)  flush (u_ext)
   end subroutine cmd_show_execute
 
 @ %def cmd_show_execute
 @
 \subsubsection{Clear values}
 This command clears the current values of variables or other objects,
 where this makes sense.  It parallels the [[show]] command.  The
 objects are cleared, but not deleted.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_clear_t
      private
      type(string_t), dimension(:), allocatable :: name
    contains
    <<Commands: cmd clear: TBP>>
   end type cmd_clear_t
 
 @ %def cmd_clear_t
 @ Output: list the names of the objects to be cleared.
 <<Commands: cmd clear: TBP>>=
   procedure :: write => cmd_clear_write
 <<Commands: procedures>>=
   subroutine cmd_clear_write (cmd, unit, indent)
     class(cmd_clear_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "clear: "
     if (allocated (cmd%name)) then
        do i = 1, size (cmd%name)
           write (u, "(1x,A)", advance="no")  char (cmd%name(i))
        end do
        write (u, *)
     else
        write (u, "(5x,A)")  "[undefined]"
     end if
   end subroutine cmd_clear_write
 
 @ %def cmd_clear_write
 @ Compile.  Allocate an array which is filled with the names of the
 objects to be cleared.
 
 Note: there is currently no need to account for options, but we
 prepare for that possibility.
 <<Commands: cmd clear: TBP>>=
   procedure :: compile => cmd_clear_compile
 <<Commands: procedures>>=
   subroutine cmd_clear_compile (cmd, global)
     class(cmd_clear_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
     type(string_t) :: key
     integer :: i, n_args
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
     if (associated (pn_arg)) then
        select case (char (parse_node_get_rule_key (pn_arg)))
        case ("clear_arg")
           cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
        case default
           cmd%pn_opt => pn_arg
           pn_arg => null ()
        end select
     end if
     call cmd%compile_options (global)
     if (associated (pn_arg)) then
        n_args = parse_node_get_n_sub (pn_arg)
        allocate (cmd%name (n_args))
        pn_var => parse_node_get_sub_ptr (pn_arg)
        i = 0
        do while (associated (pn_var))
           i = i + 1
           select case (char (parse_node_get_rule_key (pn_var)))
           case ("beams", "iterations", &
                 "cuts", "weight", &
                 "scale", "factorization_scale", "renormalization_scale", &
                 "selection", "reweight", "analysis", &
                 "unstable", "polarized", &
                 "expect")
              cmd%name(i) = parse_node_get_key (pn_var)
           case ("log_var", "string_var")
              pn_prefix => parse_node_get_sub_ptr (pn_var)
              pn_name => parse_node_get_next_ptr (pn_prefix)
              key = parse_node_get_key (pn_prefix)
              if (associated (pn_name)) then
                 select case (char (parse_node_get_rule_key (pn_name)))
                 case ("var_name")
                    select case (char (key))
                    case ("?", "$")  ! $ sign
                       cmd%name(i) = key // parse_node_get_string (pn_name)
                    end select
                 case default
                    call parse_node_mismatch &
                         ("var_name",  pn_name)
                 end select
              else
                 cmd%name(i) = key
              end if
           case default
              cmd%name(i) = parse_node_get_string (pn_var)
           end select
           pn_var => parse_node_get_next_ptr (pn_var)
        end do
     else
        allocate (cmd%name (0))
     end if
   end subroutine cmd_clear_compile
 
 @ %def cmd_clear_compile
 @ Execute.  Scan the list of objects to clear.
 
 Objects that can be shown but not cleared: model, library, results
 <<Commands: cmd clear: TBP>>=
   procedure :: execute => cmd_clear_execute
 <<Commands: procedures>>=
   subroutine cmd_clear_execute (cmd, global)
     class(cmd_clear_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     integer :: i
     logical :: success
     type(var_list_t), pointer :: model_vars
     if (size (cmd%name) == 0) then
        call msg_warning ("clear: no object specified")
     else
        do i = 1, size (cmd%name)
           success = .true.
           select case (char (cmd%name(i)))
           case ("beams")
              call cmd%local%clear_beams ()
           case ("iterations")
              call cmd%local%it_list%clear ()
           case ("polarized")
              call cmd%local%model%clear_polarized ()
           case ("unstable")
              call cmd%local%model%clear_unstable ()
           case ("cuts", "weight", "scale", &
                "factorization_scale", "renormalization_scale", &
                "selection", "reweight", "analysis")
              call cmd%local%pn%clear (cmd%name(i))
           case ("expect")
              call expect_clear ()
           case default
              if (analysis_exists (cmd%name(i))) then
                 call analysis_clear (cmd%name(i))
              else if (cmd%local%var_list%contains (cmd%name(i))) then
                 if (.not. cmd%local%var_list%is_locked (cmd%name(i))) then
                    call cmd%local%var_list%unset (cmd%name(i))
                 else
                    call msg_error ("clear: variable '" // char (cmd%name(i)) &
                         // "' is locked and can't be cleared")
                    success = .false.
                 end if
              else if (associated (cmd%local%model)) then
                 model_vars => cmd%local%model%get_var_list_ptr ()
                 if (model_vars%contains (cmd%name(i), follow_link=.false.)) then
                    call msg_error ("clear: variable '" // char (cmd%name(i)) &
                         // "' is a model variable and can't be cleared")
                 else
                    call msg_error ("clear: object '" // char (cmd%name(i)) &
                         // "' not found")
                 end if
                 success = .false.
              else
                 call msg_error ("clear: object '" // char (cmd%name(i)) &
                      // "' not found")
                 success = .false.
              end if
           end select
           if (success)  call msg_message ("cleared: " // char (cmd%name(i)))
        end do
     end if
   end subroutine cmd_clear_execute
 
 @ %def cmd_clear_execute
 @
 \subsubsection{Compare values of variables to expectation}
 The implementation is similar to the [[show]] command.  There are just
 two arguments: two values that should be compared.  For providing
 local values for the numerical tolerance, the command has a local
 argument list.
 
 If the expectation fails, an error condition is recorded.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_expect_t
      private
      type(parse_node_t), pointer :: pn_lexpr => null ()
    contains
    <<Commands: cmd expect: TBP>>
   end type cmd_expect_t
 
 @ %def cmd_expect_t
 @ Simply tell the status.
 <<Commands: cmd expect: TBP>>=
   procedure :: write => cmd_expect_write
 <<Commands: procedures>>=
   subroutine cmd_expect_write (cmd, unit, indent)
     class(cmd_expect_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     if (associated (cmd%pn_lexpr)) then
        write (u, "(1x,A)")  "expect: [expression associated]"
     else
        write (u, "(1x,A)")  "expect: [undefined]"
     end if
   end subroutine cmd_expect_write
 
 @ %def cmd_expect_write
 @ Compile.  This merely assigns the parse node, the actual compilation is done
 at execution.  This is necessary because the origin of variables
 (local/global) may change during execution.
 <<Commands: cmd expect: TBP>>=
   procedure :: compile => cmd_expect_compile
 <<Commands: procedures>>=
   subroutine cmd_expect_compile (cmd, global)
     class(cmd_expect_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
     cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
     cmd%pn_lexpr => parse_node_get_sub_ptr (pn_arg)
     call cmd%compile_options (global)
   end subroutine cmd_expect_compile
 
 @ %def cmd_expect_compile
 @ Execute.  Evaluate both arguments, print them and their difference
 (if numerical), and whether they agree.  Record the result.
 <<Commands: cmd expect: TBP>>=
   procedure :: execute => cmd_expect_execute
 <<Commands: procedures>>=
   subroutine cmd_expect_execute (cmd, global)
     class(cmd_expect_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     logical :: success, is_known
     var_list => cmd%local%get_var_list_ptr ()
     success = eval_log (cmd%pn_lexpr, var_list, is_known=is_known)
     if (is_known) then
        if (success) then
           call msg_message ("expect: success")
        else
           call msg_error ("expect: failure")
        end if
     else
        call msg_error ("expect: undefined result")
        success = .false.
     end if
     call expect_record (success)
   end subroutine cmd_expect_execute
 
 @ %def cmd_expect_execute
 @
 \subsubsection{Beams}
 The beam command includes both beam and structure-function
 definition.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_beams_t
      private
      integer :: n_in = 0
      type(parse_node_p), dimension(:), allocatable :: pn_pdg
      integer :: n_sf_record = 0
      integer, dimension(:), allocatable :: n_entry
      type(parse_node_p), dimension(:,:), allocatable :: pn_sf_entry
    contains
    <<Commands: cmd beams: TBP>>
   end type cmd_beams_t
 
 @ %def cmd_beams_t
 @ Output.  The particle expressions are not resolved.
 <<Commands: cmd beams: TBP>>=
   procedure :: write => cmd_beams_write
 <<Commands: procedures>>=
   subroutine cmd_beams_write (cmd, unit, indent)
     class(cmd_beams_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     select case (cmd%n_in)
     case (1)
        write (u, "(1x,A)")  "beams: 1 [decay]"
     case (2)
        write (u, "(1x,A)")  "beams: 2 [scattering]"
     case default
        write (u, "(1x,A)")  "beams: [undefined]"
     end select
     if (allocated (cmd%n_entry)) then
        if (cmd%n_sf_record > 0) then
           write (u, "(1x,A,99(1x,I0))")  "structure function entries:", &
                cmd%n_entry
        end if
     end if
   end subroutine cmd_beams_write
 
 @ %def cmd_beams_write
 @ Compile.  Find and assign the parse nodes.
 
 Note: local environments are not yet supported.
 <<Commands: cmd beams: TBP>>=
   procedure :: compile => cmd_beams_compile
 <<Commands: procedures>>=
   subroutine cmd_beams_compile (cmd, global)
     class(cmd_beams_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_beam_def, pn_beam_spec
     type(parse_node_t), pointer :: pn_beam_list
     type(parse_node_t), pointer :: pn_codes
     type(parse_node_t), pointer :: pn_strfun_seq, pn_strfun_pair
     type(parse_node_t), pointer :: pn_strfun_def
     integer :: i
     pn_beam_def => parse_node_get_sub_ptr (cmd%pn, 3)
     pn_beam_spec => parse_node_get_sub_ptr (pn_beam_def)
     pn_strfun_seq => parse_node_get_next_ptr (pn_beam_spec)
     pn_beam_list => parse_node_get_sub_ptr (pn_beam_spec)
     call cmd%compile_options (global)
     cmd%n_in = parse_node_get_n_sub (pn_beam_list)
     allocate (cmd%pn_pdg (cmd%n_in))
     pn_codes => parse_node_get_sub_ptr (pn_beam_list)
     do i = 1, cmd%n_in
        cmd%pn_pdg(i)%ptr => pn_codes
        pn_codes => parse_node_get_next_ptr (pn_codes)
     end do
     if (associated (pn_strfun_seq)) then
        cmd%n_sf_record = parse_node_get_n_sub (pn_beam_def) - 1
        allocate (cmd%n_entry (cmd%n_sf_record), source = 1)
        allocate (cmd%pn_sf_entry (2, cmd%n_sf_record))
        do i = 1, cmd%n_sf_record
           pn_strfun_pair => parse_node_get_sub_ptr (pn_strfun_seq, 2)
           pn_strfun_def => parse_node_get_sub_ptr (pn_strfun_pair)
           cmd%pn_sf_entry(1,i)%ptr => pn_strfun_def
           pn_strfun_def => parse_node_get_next_ptr (pn_strfun_def)
           cmd%pn_sf_entry(2,i)%ptr => pn_strfun_def
           if (associated (pn_strfun_def))  cmd%n_entry(i) = 2
           pn_strfun_seq => parse_node_get_next_ptr (pn_strfun_seq)
        end do
     else
        allocate (cmd%n_entry (0))
        allocate (cmd%pn_sf_entry (0, 0))
     end if
   end subroutine cmd_beams_compile
 
 @ %def cmd_beams_compile
 @ Command execution: Determine beam particles and structure-function
 names, if any.  The results are stored in the [[beam_structure]]
 component of the [[global]] data block.
 <<Commands: cmd beams: TBP>>=
   procedure :: execute => cmd_beams_execute
 <<Commands: procedures>>=
   subroutine cmd_beams_execute (cmd, global)
     class(cmd_beams_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(pdg_array_t) :: pdg_array
     integer, dimension(:), allocatable :: pdg
     type(flavor_t), dimension(:), allocatable :: flv
     type(parse_node_t), pointer :: pn_key
     type(string_t) :: sf_name
     integer :: i, j
     call lhapdf_global_reset ()
     var_list => cmd%local%get_var_list_ptr ()
     allocate (flv (cmd%n_in))
     do i = 1, cmd%n_in
        pdg_array = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
        pdg = pdg_array
        select case (size (pdg))
        case (1)
           call flv(i)%init ( pdg(1), cmd%local%model)
        case default
           call msg_fatal ("Beams: beam particles must be unique")
        end select
     end do
     select case (cmd%n_in)
     case (1)
        if (cmd%n_sf_record > 0) then
           call msg_fatal ("Beam setup: no structure functions allowed &
                &for decay")
        end if
        call global%beam_structure%init_sf (flv%get_name ())
     case (2)
        call global%beam_structure%init_sf (flv%get_name (), cmd%n_entry)
        do i = 1, cmd%n_sf_record
           do j = 1, cmd%n_entry(i)
              pn_key => parse_node_get_sub_ptr (cmd%pn_sf_entry(j,i)%ptr)
              sf_name = parse_node_get_key (pn_key)
              call global%beam_structure%set_sf (i, j, sf_name)
           end do
        end do
     end select
   end subroutine cmd_beams_execute
 
 @ %def cmd_beams_execute
 @
 \subsubsection{Density matrices for beam polarization}
 For holding beam polarization, we define a notation and a data
 structure for sparse matrices.  The entries (and the index
 expressions) are numerical expressions, so we use evaluation trees.
 
 Each entry in the sparse matrix is an n-tuple of expressions.  The first
 tuple elements represent index values, the last one is an arbitrary
 (complex) number.  Absent expressions are replaced by default-value rules.
 
 Note: Here, and in some other commands, we would like to store an evaluation
 tree, not just a parse node pointer.  However, the current expression handler
 wants all variables defined, so the evaluation tree can only be built by
 [[evaluate]], i.e., compiled just-in-time and evaluated immediately.
 <<Commands: types>>=
   type :: sentry_expr_t
      type(parse_node_p), dimension(:), allocatable :: expr
    contains
    <<Commands: sentry expr: TBP>>
   end type sentry_expr_t
 
 @ %def sentry_expr_t
 @ Compile parse nodes into evaluation trees.
 <<Commands: sentry expr: TBP>>=
   procedure :: compile => sentry_expr_compile
 <<Commands: procedures>>=
   subroutine sentry_expr_compile (sentry, pn)
     class(sentry_expr_t), intent(out) :: sentry
     type(parse_node_t), intent(in), target :: pn
     type(parse_node_t), pointer :: pn_expr, pn_extra
     integer :: n_expr, i
     n_expr = parse_node_get_n_sub (pn)
     allocate (sentry%expr (n_expr))
     if (n_expr > 0) then
        i = 0
        pn_expr => parse_node_get_sub_ptr (pn)
        pn_extra => parse_node_get_next_ptr (pn_expr)
        do i = 1, n_expr
           sentry%expr(i)%ptr => pn_expr
           if (associated (pn_extra)) then
              pn_expr => parse_node_get_sub_ptr (pn_extra, 2)
              pn_extra => parse_node_get_next_ptr (pn_extra)
           end if
        end do
     end if
   end subroutine sentry_expr_compile
 
 @ %def sentry_expr_compile
 @ Evaluate the expressions and return an index array of predefined
 length together with a complex value.  If the value (as the last expression)
 is undefined, set it to unity.  If index values are undefined, repeat
 the previous index value.
 <<Commands: sentry expr: TBP>>=
   procedure :: evaluate => sentry_expr_evaluate
 <<Commands: procedures>>=
   subroutine sentry_expr_evaluate (sentry, index, value, global)
     class(sentry_expr_t), intent(inout) :: sentry
     integer, dimension(:), intent(out) :: index
     complex(default), intent(out) :: value
     type(rt_data_t), intent(in), target :: global
     type(var_list_t), pointer :: var_list
     integer :: i, n_expr, n_index
     type(eval_tree_t) :: eval_tree
     var_list => global%get_var_list_ptr ()
     n_expr = size (sentry%expr)
     n_index = size (index)
     if (n_expr <= n_index + 1) then
        do i = 1, min (n_expr, n_index)
           associate (expr => sentry%expr(i))
             call eval_tree%init_expr (expr%ptr, var_list)
             call eval_tree%evaluate ()
             if (eval_tree%is_known ()) then
                index(i) = eval_tree%get_int ()
             else
                call msg_fatal ("Evaluating density matrix: undefined index")
             end if
           end associate
        end do
        do i = n_expr + 1, n_index
           index(i) = index(n_expr)
        end do
        if (n_expr == n_index + 1) then
           associate (expr => sentry%expr(n_expr))
             call eval_tree%init_expr (expr%ptr, var_list)
             call eval_tree%evaluate ()
             if (eval_tree%is_known ()) then
                value = eval_tree%get_cmplx ()
             else
                call msg_fatal ("Evaluating density matrix: undefined index")
             end if
             call eval_tree%final ()
           end associate
        else
           value = 1
        end if
     else
        call msg_fatal ("Evaluating density matrix: index expression too long")
     end if
   end subroutine sentry_expr_evaluate
 
 @ %def sentry_expr_evaluate
 @ The sparse matrix itself consists of an arbitrary number of entries.
 <<Commands: types>>=
   type :: smatrix_expr_t
      type(sentry_expr_t), dimension(:), allocatable :: entry
    contains
    <<Commands: smatrix expr: TBP>>
   end type smatrix_expr_t
 
 @ %def smatrix_expr_t
 @ Compile: assign sub-nodes to sentry-expressions and compile those.
 <<Commands: smatrix expr: TBP>>=
   procedure :: compile => smatrix_expr_compile
 <<Commands: procedures>>=
   subroutine smatrix_expr_compile (smatrix_expr, pn)
     class(smatrix_expr_t), intent(out) :: smatrix_expr
     type(parse_node_t), intent(in), target :: pn
     type(parse_node_t), pointer :: pn_arg, pn_entry
     integer :: n_entry, i
     pn_arg => parse_node_get_sub_ptr (pn, 2)
     if (associated (pn_arg)) then
        n_entry = parse_node_get_n_sub (pn_arg)
        allocate (smatrix_expr%entry (n_entry))
        pn_entry => parse_node_get_sub_ptr (pn_arg)
        do i = 1, n_entry
           call smatrix_expr%entry(i)%compile (pn_entry)
           pn_entry => parse_node_get_next_ptr (pn_entry)
        end do
     else
        allocate (smatrix_expr%entry (0))
     end if
   end subroutine smatrix_expr_compile
 
 @ %def smatrix_expr_compile
 @ Evaluate the entries and build a new [[smatrix]] object, which
 contains just the numerical results.
 <<Commands: smatrix expr: TBP>>=
   procedure :: evaluate => smatrix_expr_evaluate
 <<Commands: procedures>>=
   subroutine smatrix_expr_evaluate (smatrix_expr, smatrix, global)
     class(smatrix_expr_t), intent(inout) :: smatrix_expr
     type(smatrix_t), intent(out) :: smatrix
     type(rt_data_t), intent(in), target :: global
     integer, dimension(2) :: idx
     complex(default) :: value
     integer :: i, n_entry
     n_entry = size (smatrix_expr%entry)
     call smatrix%init (2, n_entry)
     do i = 1, n_entry
        call smatrix_expr%entry(i)%evaluate (idx, value, global)
        call smatrix%set_entry (i, idx, value)
     end do
   end subroutine smatrix_expr_evaluate
 
 @ %def smatrix_expr_evaluate
 @
 \subsubsection{Beam polarization density}
 
 The beam polarization command defines spin density matrix for one or
 two beams (scattering or decay).
 <<Commands: types>>=
   type, extends (command_t) :: cmd_beams_pol_density_t
      private
      integer :: n_in = 0
      type(smatrix_expr_t), dimension(:), allocatable :: smatrix
    contains
    <<Commands: cmd beams pol density: TBP>>
   end type cmd_beams_pol_density_t
 
 @ %def cmd_beams_pol_density_t
 @ Output.
 <<Commands: cmd beams pol density: TBP>>=
   procedure :: write => cmd_beams_pol_density_write
 <<Commands: procedures>>=
   subroutine cmd_beams_pol_density_write (cmd, unit, indent)
     class(cmd_beams_pol_density_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     select case (cmd%n_in)
     case (1)
        write (u, "(1x,A)")  "beams polarization setup: 1 [decay]"
     case (2)
        write (u, "(1x,A)")  "beams polarization setup: 2 [scattering]"
     case default
        write (u, "(1x,A)")  "beams polarization setup: [undefined]"
     end select
   end subroutine cmd_beams_pol_density_write
 
 @ %def cmd_beams_pol_density_write
 @ Compile.  Find and assign the parse nodes.
 
 Note: local environments are not yet supported.
 <<Commands: cmd beams pol density: TBP>>=
   procedure :: compile => cmd_beams_pol_density_compile
 <<Commands: procedures>>=
   subroutine cmd_beams_pol_density_compile (cmd, global)
     class(cmd_beams_pol_density_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_pol_spec, pn_smatrix
     integer :: i
     pn_pol_spec => parse_node_get_sub_ptr (cmd%pn, 3)
     call cmd%compile_options (global)
     cmd%n_in = parse_node_get_n_sub (pn_pol_spec)
     allocate (cmd%smatrix (cmd%n_in))
     pn_smatrix => parse_node_get_sub_ptr (pn_pol_spec)
     do i = 1, cmd%n_in
        call cmd%smatrix(i)%compile (pn_smatrix)
        pn_smatrix => parse_node_get_next_ptr (pn_smatrix)
     end do
   end subroutine cmd_beams_pol_density_compile
 
 @ %def cmd_beams_pol_density_compile
 @ Command execution: Fill polarization density matrices.  No check
 yet, the matrices are checked and normalized when the actual beam
 object is created, just before integration.  For intermediate storage,
 we use the [[beam_structure]] object in the [[global]] data set.
 <<Commands: cmd beams pol density: TBP>>=
   procedure :: execute => cmd_beams_pol_density_execute
 <<Commands: procedures>>=
   subroutine cmd_beams_pol_density_execute (cmd, global)
     class(cmd_beams_pol_density_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(smatrix_t) :: smatrix
     integer :: i
     call global%beam_structure%init_pol (cmd%n_in)
     do i = 1, cmd%n_in
        call cmd%smatrix(i)%evaluate (smatrix, global)
        call global%beam_structure%set_smatrix (i, smatrix)
     end do
   end subroutine cmd_beams_pol_density_execute
 
 @ %def cmd_beams_pol_density_execute
 @
 \subsubsection{Beam polarization fraction}
 In addition to the polarization density matrix, we can independently
 specify the polarization fraction for one or both beams.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_beams_pol_fraction_t
      private
      integer :: n_in = 0
      type(parse_node_p), dimension(:), allocatable :: expr
    contains
    <<Commands: cmd beams pol fraction: TBP>>
   end type cmd_beams_pol_fraction_t
 
 @ %def cmd_beams_pol_fraction_t
 @ Output.
 <<Commands: cmd beams pol fraction: TBP>>=
   procedure :: write => cmd_beams_pol_fraction_write
 <<Commands: procedures>>=
   subroutine cmd_beams_pol_fraction_write (cmd, unit, indent)
     class(cmd_beams_pol_fraction_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     select case (cmd%n_in)
     case (1)
        write (u, "(1x,A)")  "beams polarization fraction: 1 [decay]"
     case (2)
        write (u, "(1x,A)")  "beams polarization fraction: 2 [scattering]"
     case default
        write (u, "(1x,A)")  "beams polarization fraction: [undefined]"
     end select
   end subroutine cmd_beams_pol_fraction_write
 
 @ %def cmd_beams_pol_fraction_write
 @ Compile.  Find and assign the parse nodes.
 
 Note: local environments are not yet supported.
 <<Commands: cmd beams pol fraction: TBP>>=
   procedure :: compile => cmd_beams_pol_fraction_compile
 <<Commands: procedures>>=
   subroutine cmd_beams_pol_fraction_compile (cmd, global)
     class(cmd_beams_pol_fraction_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_frac_spec, pn_expr
     integer :: i
     pn_frac_spec => parse_node_get_sub_ptr (cmd%pn, 3)
     call cmd%compile_options (global)
     cmd%n_in = parse_node_get_n_sub (pn_frac_spec)
     allocate (cmd%expr (cmd%n_in))
     pn_expr => parse_node_get_sub_ptr (pn_frac_spec)
     do i = 1, cmd%n_in
        cmd%expr(i)%ptr => pn_expr
        pn_expr => parse_node_get_next_ptr (pn_expr)
     end do
   end subroutine cmd_beams_pol_fraction_compile
 
 @ %def cmd_beams_pol_fraction_compile
 @ Command execution: Retrieve the numerical values of the beam
 polarization fractions.  The results are stored in the
 [[beam_structure]] component of the [[global]] data block.
 <<Commands: cmd beams pol fraction: TBP>>=
   procedure :: execute => cmd_beams_pol_fraction_execute
 <<Commands: procedures>>=
   subroutine cmd_beams_pol_fraction_execute (cmd, global)
     class(cmd_beams_pol_fraction_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     real(default), dimension(:), allocatable :: pol_f
     type(eval_tree_t) :: expr
     integer :: i
     var_list => global%get_var_list_ptr ()
     allocate (pol_f (cmd%n_in))
     do i = 1, cmd%n_in
        call expr%init_expr (cmd%expr(i)%ptr, var_list)
        call expr%evaluate ()
        if (expr%is_known ()) then
           pol_f(i) = expr%get_real ()
        else
           call msg_fatal ("beams polarization fraction: undefined value")
        end if
        call expr%final ()
     end do
     call global%beam_structure%set_pol_f (pol_f)
   end subroutine cmd_beams_pol_fraction_execute
 
 @ %def cmd_beams_pol_fraction_execute
 @
 \subsubsection{Beam momentum}
 This is completely analogous to the previous command, hence we can use
 inheritance.
 <<Commands: types>>=
   type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_momentum_t
    contains
    <<Commands: cmd beams momentum: TBP>>
   end type cmd_beams_momentum_t
 
 @ %def cmd_beams_momentum_t
 @ Output.
 <<Commands: cmd beams momentum: TBP>>=
   procedure :: write => cmd_beams_momentum_write
 <<Commands: procedures>>=
   subroutine cmd_beams_momentum_write (cmd, unit, indent)
     class(cmd_beams_momentum_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     select case (cmd%n_in)
     case (1)
        write (u, "(1x,A)")  "beams momentum: 1 [decay]"
     case (2)
        write (u, "(1x,A)")  "beams momentum: 2 [scattering]"
     case default
        write (u, "(1x,A)")  "beams momentum: [undefined]"
     end select
   end subroutine cmd_beams_momentum_write
 
 @ %def cmd_beams_momentum_write
 @ Compile: inherited.
 
 Command execution: Not inherited, but just the error string and the final
 command are changed.
 <<Commands: cmd beams momentum: TBP>>=
   procedure :: execute => cmd_beams_momentum_execute
 <<Commands: procedures>>=
   subroutine cmd_beams_momentum_execute (cmd, global)
     class(cmd_beams_momentum_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     real(default), dimension(:), allocatable :: p
     type(eval_tree_t) :: expr
     integer :: i
     var_list => global%get_var_list_ptr ()
     allocate (p (cmd%n_in))
     do i = 1, cmd%n_in
        call expr%init_expr (cmd%expr(i)%ptr, var_list)
        call expr%evaluate ()
        if (expr%is_known ()) then
           p(i) = expr%get_real ()
        else
           call msg_fatal ("beams momentum: undefined value")
        end if
        call expr%final ()
     end do
     call global%beam_structure%set_momentum (p)
   end subroutine cmd_beams_momentum_execute
 
 @ %def cmd_beams_momentum_execute
 @
 \subsubsection{Beam angles}
 Again, this is analogous.  There are two angles, polar angle $\theta$
 and azimuthal angle $\phi$, which can be set independently for both beams.
 <<Commands: types>>=
   type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_theta_t
    contains
    <<Commands: cmd beams theta: TBP>>
   end type cmd_beams_theta_t
 
   type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_phi_t
    contains
    <<Commands: cmd beams phi: TBP>>
   end type cmd_beams_phi_t
 
 @ %def cmd_beams_theta_t
 @ %def cmd_beams_phi_t
 @ Output.
 <<Commands: cmd beams theta: TBP>>=
   procedure :: write => cmd_beams_theta_write
 <<Commands: cmd beams phi: TBP>>=
   procedure :: write => cmd_beams_phi_write
 <<Commands: procedures>>=
   subroutine cmd_beams_theta_write (cmd, unit, indent)
     class(cmd_beams_theta_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     select case (cmd%n_in)
     case (1)
        write (u, "(1x,A)")  "beams theta: 1 [decay]"
     case (2)
        write (u, "(1x,A)")  "beams theta: 2 [scattering]"
     case default
        write (u, "(1x,A)")  "beams theta: [undefined]"
     end select
   end subroutine cmd_beams_theta_write
 
   subroutine cmd_beams_phi_write (cmd, unit, indent)
     class(cmd_beams_phi_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     select case (cmd%n_in)
     case (1)
        write (u, "(1x,A)")  "beams phi: 1 [decay]"
     case (2)
        write (u, "(1x,A)")  "beams phi: 2 [scattering]"
     case default
        write (u, "(1x,A)")  "beams phi: [undefined]"
     end select
   end subroutine cmd_beams_phi_write
 
 @ %def cmd_beams_theta_write
 @ %def cmd_beams_phi_write
 @ Compile: inherited.
 
 Command execution: Not inherited, but just the error string and the final
 command are changed.
 <<Commands: cmd beams theta: TBP>>=
   procedure :: execute => cmd_beams_theta_execute
 <<Commands: cmd beams phi: TBP>>=
   procedure :: execute => cmd_beams_phi_execute
 <<Commands: procedures>>=
   subroutine cmd_beams_theta_execute (cmd, global)
     class(cmd_beams_theta_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     real(default), dimension(:), allocatable :: theta
     type(eval_tree_t) :: expr
     integer :: i
     var_list => global%get_var_list_ptr ()
     allocate (theta (cmd%n_in))
     do i = 1, cmd%n_in
        call expr%init_expr (cmd%expr(i)%ptr, var_list)
        call expr%evaluate ()
        if (expr%is_known ()) then
           theta(i) = expr%get_real ()
        else
           call msg_fatal ("beams theta: undefined value")
        end if
        call expr%final ()
     end do
     call global%beam_structure%set_theta (theta)
   end subroutine cmd_beams_theta_execute
 
   subroutine cmd_beams_phi_execute (cmd, global)
     class(cmd_beams_phi_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     real(default), dimension(:), allocatable :: phi
     type(eval_tree_t) :: expr
     integer :: i
     var_list => global%get_var_list_ptr ()
     allocate (phi (cmd%n_in))
     do i = 1, cmd%n_in
        call expr%init_expr (cmd%expr(i)%ptr, var_list)
        call expr%evaluate ()
        if (expr%is_known ()) then
           phi(i) = expr%get_real ()
        else
           call msg_fatal ("beams phi: undefined value")
        end if
        call expr%final ()
     end do
     call global%beam_structure%set_phi (phi)
   end subroutine cmd_beams_phi_execute
 
 @ %def cmd_beams_theta_execute
 @ %def cmd_beams_phi_execute
 @
 \subsubsection{Cuts}
 Define a cut expression.  We store the parse tree for the right-hand
 side instead of compiling it.  Compilation is deferred to the process
 environment where the cut expression is used.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_cuts_t
      private
      type(parse_node_t), pointer :: pn_lexpr => null ()
    contains
    <<Commands: cmd cuts: TBP>>
   end type cmd_cuts_t
 
 @ %def cmd_cuts_t
 @ Output.  Do not print the parse tree, since this may get cluttered.
 Just a message that cuts have been defined.
 <<Commands: cmd cuts: TBP>>=
   procedure :: write => cmd_cuts_write
 <<Commands: procedures>>=
   subroutine cmd_cuts_write (cmd, unit, indent)
     class(cmd_cuts_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "cuts: [defined]"
   end subroutine cmd_cuts_write
 
 @ %def cmd_cuts_write
 @ Compile.  Simply store the parse (sub)tree.
 <<Commands: cmd cuts: TBP>>=
   procedure :: compile => cmd_cuts_compile
 <<Commands: procedures>>=
   subroutine cmd_cuts_compile (cmd, global)
     class(cmd_cuts_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3)
   end subroutine cmd_cuts_compile
 
 @ %def cmd_cuts_compile
 @ Instead of evaluating the cut expression, link the parse tree to the
 global data set, such that it is compiled and executed in the
 appropriate process context.
 <<Commands: cmd cuts: TBP>>=
   procedure :: execute => cmd_cuts_execute
 <<Commands: procedures>>=
   subroutine cmd_cuts_execute (cmd, global)
     class(cmd_cuts_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     global%pn%cuts_lexpr => cmd%pn_lexpr
   end subroutine cmd_cuts_execute
 
 @ %def cmd_cuts_execute
 @
 \subsubsection{General, Factorization and Renormalization Scales}
 Define a scale expression for either the renormalization or the
 factorization scale.  We store the parse tree for the right-hand
 side instead of compiling it.  Compilation is deferred to the process
 environment where the expression is used.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_scale_t
      private
      type(parse_node_t), pointer :: pn_expr => null ()
    contains
    <<Commands: cmd scale: TBP>>
   end type cmd_scale_t
 
 @ %def cmd_scale_t
 <<Commands: types>>=
   type, extends (command_t) :: cmd_fac_scale_t
      private
      type(parse_node_t), pointer :: pn_expr => null ()
    contains
    <<Commands: cmd fac scale: TBP>>
   end type cmd_fac_scale_t
 
 @ %def cmd_fac_scale_t
 <<Commands: types>>=
   type, extends (command_t) :: cmd_ren_scale_t
      private
      type(parse_node_t), pointer :: pn_expr => null ()
    contains
    <<Commands: cmd ren scale: TBP>>
   end type cmd_ren_scale_t
 
 @ %def cmd_ren_scale_t
 @ Output. Do not print the parse tree, since this may get cluttered.
 Just a message that scale, renormalization and factorization have been
 defined, respectively.
 <<Commands: cmd scale: TBP>>=
   procedure :: write => cmd_scale_write
 <<Commands: procedures>>=
   subroutine cmd_scale_write (cmd, unit, indent)
     class(cmd_scale_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "scale: [defined]"
   end subroutine cmd_scale_write
 
 @ %def cmd_scale_write
 @
 <<Commands: cmd fac scale: TBP>>=
   procedure :: write => cmd_fac_scale_write
 <<Commands: procedures>>=
   subroutine cmd_fac_scale_write (cmd, unit, indent)
     class(cmd_fac_scale_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "factorization scale: [defined]"
   end subroutine cmd_fac_scale_write
 
 @ %def cmd_fac_scale_write
 @
 <<Commands: cmd ren scale: TBP>>=
   procedure :: write => cmd_ren_scale_write
 <<Commands: procedures>>=
   subroutine cmd_ren_scale_write (cmd, unit, indent)
     class(cmd_ren_scale_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "renormalization scale: [defined]"
   end subroutine cmd_ren_scale_write
 
 @ %def cmd_ren_scale_write
 @ Compile.  Simply store the parse (sub)tree.
 <<Commands: cmd scale: TBP>>=
   procedure :: compile => cmd_scale_compile
 <<Commands: procedures>>=
   subroutine cmd_scale_compile (cmd, global)
     class(cmd_scale_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
   end subroutine cmd_scale_compile
 
 @ %def cmd_scale_compile
 @
 <<Commands: cmd fac scale: TBP>>=
   procedure :: compile => cmd_fac_scale_compile
 <<Commands: procedures>>=
   subroutine cmd_fac_scale_compile (cmd, global)
     class(cmd_fac_scale_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
   end subroutine cmd_fac_scale_compile
 
 @ %def cmd_fac_scale_compile
 @
 <<Commands: cmd ren scale: TBP>>=
   procedure :: compile => cmd_ren_scale_compile
 <<Commands: procedures>>=
   subroutine cmd_ren_scale_compile (cmd, global)
     class(cmd_ren_scale_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
   end subroutine cmd_ren_scale_compile
 
 @ %def cmd_ren_scale_compile
 @ Instead of evaluating the scale expression, link the parse tree to the
 global data set, such that it is compiled and executed in the
 appropriate process context.
 <<Commands: cmd scale: TBP>>=
   procedure :: execute => cmd_scale_execute
 <<Commands: procedures>>=
   subroutine cmd_scale_execute (cmd, global)
     class(cmd_scale_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     global%pn%scale_expr => cmd%pn_expr
   end subroutine cmd_scale_execute
 
 @ %def cmd_scale_execute
 @
 <<Commands: cmd fac scale: TBP>>=
   procedure :: execute => cmd_fac_scale_execute
 <<Commands: procedures>>=
   subroutine cmd_fac_scale_execute (cmd, global)
     class(cmd_fac_scale_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     global%pn%fac_scale_expr => cmd%pn_expr
   end subroutine cmd_fac_scale_execute
 
 @ %def cmd_fac_scale_execute
 @
 <<Commands: cmd ren scale: TBP>>=
   procedure :: execute => cmd_ren_scale_execute
 <<Commands: procedures>>=
   subroutine cmd_ren_scale_execute (cmd, global)
     class(cmd_ren_scale_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     global%pn%ren_scale_expr => cmd%pn_expr
   end subroutine cmd_ren_scale_execute
 
 @ %def cmd_ren_scale_execute
 @
 \subsubsection{Weight}
 Define a weight expression. The weight is applied to a process to be
 integrated, event by event. We store the parse tree for the right-hand
 side instead of compiling it. Compilation is deferred to the process
 environment where the expression is used.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_weight_t
      private
      type(parse_node_t), pointer :: pn_expr => null ()
    contains
    <<Commands: cmd weight: TBP>>
   end type cmd_weight_t
 
 @ %def cmd_weight_t
 @ Output. Do not print the parse tree, since this may get cluttered.
 Just a message that scale, renormalization and factorization have been
 defined, respectively.
 <<Commands: cmd weight: TBP>>=
   procedure :: write => cmd_weight_write
 <<Commands: procedures>>=
   subroutine cmd_weight_write (cmd, unit, indent)
     class(cmd_weight_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "weight expression: [defined]"
   end subroutine cmd_weight_write
 
 @ %def cmd_weight_write
 @ Compile.  Simply store the parse (sub)tree.
 <<Commands: cmd weight: TBP>>=
   procedure :: compile => cmd_weight_compile
 <<Commands: procedures>>=
   subroutine cmd_weight_compile (cmd, global)
     class(cmd_weight_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
   end subroutine cmd_weight_compile
 
 @ %def cmd_weight_compile
 @ Instead of evaluating the expression, link the parse tree to the
 global data set, such that it is compiled and executed in the
 appropriate process context.
 <<Commands: cmd weight: TBP>>=
   procedure :: execute => cmd_weight_execute
 <<Commands: procedures>>=
   subroutine cmd_weight_execute (cmd, global)
     class(cmd_weight_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     global%pn%weight_expr => cmd%pn_expr
   end subroutine cmd_weight_execute
 
 @ %def cmd_weight_execute
 @
 \subsubsection{Selection}
 Define a selection expression.  This is to be applied upon simulation or
 event-file rescanning, event by event.  We store the parse tree for the
 right-hand side instead of compiling it.  Compilation is deferred to the
 environment where the expression is used.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_selection_t
      private
      type(parse_node_t), pointer :: pn_expr => null ()
    contains
    <<Commands: cmd selection: TBP>>
   end type cmd_selection_t
 
 @ %def cmd_selection_t
 @ Output. Do not print the parse tree, since this may get cluttered.
 Just a message that scale, renormalization and factorization have been
 defined, respectively.
 <<Commands: cmd selection: TBP>>=
   procedure :: write => cmd_selection_write
 <<Commands: procedures>>=
   subroutine cmd_selection_write (cmd, unit, indent)
     class(cmd_selection_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "selection expression: [defined]"
   end subroutine cmd_selection_write
 
 @ %def cmd_selection_write
 @ Compile.  Simply store the parse (sub)tree.
 <<Commands: cmd selection: TBP>>=
   procedure :: compile => cmd_selection_compile
 <<Commands: procedures>>=
   subroutine cmd_selection_compile (cmd, global)
     class(cmd_selection_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
   end subroutine cmd_selection_compile
 
 @ %def cmd_selection_compile
 @ Instead of evaluating the expression, link the parse tree to the
 global data set, such that it is compiled and executed in the
 appropriate process context.
 <<Commands: cmd selection: TBP>>=
   procedure :: execute => cmd_selection_execute
 <<Commands: procedures>>=
   subroutine cmd_selection_execute (cmd, global)
     class(cmd_selection_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     global%pn%selection_lexpr => cmd%pn_expr
   end subroutine cmd_selection_execute
 
 @ %def cmd_selection_execute
 @
 \subsubsection{Reweight}
 Define a reweight expression.  This is to be applied upon simulation or
 event-file rescanning, event by event.  We store the parse tree for the
 right-hand side instead of compiling it.  Compilation is deferred to the
 environment where the expression is used.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_reweight_t
      private
      type(parse_node_t), pointer :: pn_expr => null ()
    contains
    <<Commands: cmd reweight: TBP>>
   end type cmd_reweight_t
 
 @ %def cmd_reweight_t
 @ Output. Do not print the parse tree, since this may get cluttered.
 Just a message that scale, renormalization and factorization have been
 defined, respectively.
 <<Commands: cmd reweight: TBP>>=
   procedure :: write => cmd_reweight_write
 <<Commands: procedures>>=
   subroutine cmd_reweight_write (cmd, unit, indent)
     class(cmd_reweight_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "reweight expression: [defined]"
   end subroutine cmd_reweight_write
 
 @ %def cmd_reweight_write
 @ Compile.  Simply store the parse (sub)tree.
 <<Commands: cmd reweight: TBP>>=
   procedure :: compile => cmd_reweight_compile
 <<Commands: procedures>>=
   subroutine cmd_reweight_compile (cmd, global)
     class(cmd_reweight_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
   end subroutine cmd_reweight_compile
 
 @ %def cmd_reweight_compile
 @ Instead of evaluating the expression, link the parse tree to the
 global data set, such that it is compiled and executed in the
 appropriate process context.
 <<Commands: cmd reweight: TBP>>=
   procedure :: execute => cmd_reweight_execute
 <<Commands: procedures>>=
   subroutine cmd_reweight_execute (cmd, global)
     class(cmd_reweight_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     global%pn%reweight_expr => cmd%pn_expr
   end subroutine cmd_reweight_execute
 
 @ %def cmd_reweight_execute
 @
 \subsubsection{Alternative Simulation Setups}
 Together with simulation, we can re-evaluate event weights in the context of
 alternative setups.  The [[cmd_alt_setup_t]] object is designed to hold these
 setups, which are brace-enclosed command lists.  Compilation is deferred to
 the simulation environment where the setup expression is used.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_alt_setup_t
      private
      type(parse_node_p), dimension(:), allocatable :: setup
    contains
    <<Commands: cmd alt setup: TBP>>
   end type cmd_alt_setup_t
 
 @ %def cmd_alt_setup_t
 @ Output.  Print just a message that the alternative setup list has been
 defined.
 <<Commands: cmd alt setup: TBP>>=
   procedure :: write => cmd_alt_setup_write
 <<Commands: procedures>>=
   subroutine cmd_alt_setup_write (cmd, unit, indent)
     class(cmd_alt_setup_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,I0,A)")  "alt_setup: ", size (cmd%setup), " entries"
   end subroutine cmd_alt_setup_write
 
 @ %def cmd_alt_setup_write
 @ Compile.  Store the parse sub-trees in an array.
 <<Commands: cmd alt setup: TBP>>=
   procedure :: compile => cmd_alt_setup_compile
 <<Commands: procedures>>=
   subroutine cmd_alt_setup_compile (cmd, global)
     class(cmd_alt_setup_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_list, pn_setup
     integer :: i
     pn_list => parse_node_get_sub_ptr (cmd%pn, 3)
     if (associated (pn_list)) then
        allocate (cmd%setup (parse_node_get_n_sub (pn_list)))
        i = 1
        pn_setup => parse_node_get_sub_ptr (pn_list)
        do while (associated (pn_setup))
           cmd%setup(i)%ptr => pn_setup
           i = i + 1
           pn_setup => parse_node_get_next_ptr (pn_setup)
        end do
     else
        allocate (cmd%setup (0))
     end if
   end subroutine cmd_alt_setup_compile
 
 @ %def cmd_alt_setup_compile
 @ Execute.  Transfer the array of command lists to the global environment.
 <<Commands: cmd alt setup: TBP>>=
   procedure :: execute => cmd_alt_setup_execute
 <<Commands: procedures>>=
   subroutine cmd_alt_setup_execute (cmd, global)
     class(cmd_alt_setup_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     if (allocated (global%pn%alt_setup))  deallocate (global%pn%alt_setup)
     allocate (global%pn%alt_setup (size (cmd%setup)))
     global%pn%alt_setup = cmd%setup
   end subroutine cmd_alt_setup_execute
 
 @ %def cmd_alt_setup_execute
 @
 \subsubsection{Integration}
 Integrate several processes, consecutively with identical parameters.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_integrate_t
      private
      integer :: n_proc = 0
      type(string_t), dimension(:), allocatable :: process_id
    contains
    <<Commands: cmd integrate: TBP>>
   end type cmd_integrate_t
 
 @ %def cmd_integrate_t
 @ Output: we know the process IDs.
 <<Commands: cmd integrate: TBP>>=
   procedure :: write => cmd_integrate_write
 <<Commands: procedures>>=
   subroutine cmd_integrate_write (cmd, unit, indent)
     class(cmd_integrate_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "integrate ("
     do i = 1, cmd%n_proc
        if (i > 1)  write (u, "(A,1x)", advance="no")  ","
        write (u, "(A)", advance="no")  char (cmd%process_id(i))
     end do
     write (u, "(A)")  ")"
   end subroutine cmd_integrate_write
 
 @ %def cmd_integrate_write
 @ Compile.
 <<Commands: cmd integrate: TBP>>=
   procedure :: compile => cmd_integrate_compile
 <<Commands: procedures>>=
   subroutine cmd_integrate_compile (cmd, global)
     class(cmd_integrate_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_proclist, pn_proc
     integer :: i
     pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2)
     cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
     call cmd%compile_options (global)
     cmd%n_proc = parse_node_get_n_sub (pn_proclist)
     allocate (cmd%process_id (cmd%n_proc))
     pn_proc => parse_node_get_sub_ptr (pn_proclist)
     do i = 1, cmd%n_proc
        cmd%process_id(i) = parse_node_get_string (pn_proc)
        call global%process_stack%init_result_vars (cmd%process_id(i))
        pn_proc => parse_node_get_next_ptr (pn_proc)
     end do
   end subroutine cmd_integrate_compile
 
 @ %def cmd_integrate_compile
 @ Command execution.  Integrate the process(es) with the predefined number
 of passes, iterations and calls.  For structure functions, cuts,
 weight and scale, use local definitions if present; by default, the local
 definitions are initialized with the global ones.
 
 The [[integrate]] procedure should take its input from the currently
 active local environment, but produce a process record in the stack of
 the global environment.
 
 Since the process acquires a snapshot of the variable list, so if the global
 list (or the local one) is deleted, this does no harm.  This implies that
 later changes of the variable list do not affect the stored process.
 <<Commands: cmd integrate: TBP>>=
   procedure :: execute => cmd_integrate_execute
 <<Commands: procedures>>=
   subroutine cmd_integrate_execute (cmd, global)
     class(cmd_integrate_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     integer :: i
     if (debug_on) call msg_debug (D_CORE, "cmd_integrate_execute")
     do i = 1, cmd%n_proc
        if (debug_on) call msg_debug (D_CORE, "cmd%process_id(i) ", cmd%process_id(i))
        call integrate_process (cmd%process_id(i), cmd%local, global)
        call global%process_stack%fill_result_vars (cmd%process_id(i))
        call global%process_stack%update_result_vars &
             (cmd%process_id(i), global%var_list)
        if (signal_is_pending ())  return
     end do
   end subroutine cmd_integrate_execute
 
 @ %def cmd_integrate_execute
 @
 \subsubsection{Observables}
 Declare an observable.  After the declaration, it can be used to
 record data, and at the end one can retrieve average and error.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_observable_t
      private
      type(string_t) :: id
    contains
    <<Commands: cmd observable: TBP>>
   end type cmd_observable_t
 
 @ %def cmd_observable_t
 @ Output.  We know the ID.
 <<Commands: cmd observable: TBP>>=
   procedure :: write => cmd_observable_write
 <<Commands: procedures>>=
   subroutine cmd_observable_write (cmd, unit, indent)
     class(cmd_observable_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,A)")  "observable: ", char (cmd%id)
   end subroutine cmd_observable_write
 
 @ %def cmd_observable_write
 @ Compile.  Just record the observable ID.
 <<Commands: cmd observable: TBP>>=
   procedure :: compile => cmd_observable_compile
 <<Commands: procedures>>=
   subroutine cmd_observable_compile (cmd, global)
     class(cmd_observable_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_tag
     pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
     if (associated (pn_tag)) then
        cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
     end if
     call cmd%compile_options (global)
     select case (char (parse_node_get_rule_key (pn_tag)))
     case ("analysis_id")
        cmd%id = parse_node_get_string (pn_tag)
     case default
        call msg_bug ("observable: name expression not implemented (yet)")
     end select
   end subroutine cmd_observable_compile
 
 @ %def cmd_observable_compile
 @ Command execution.  This declares the observable and allocates it in
 the analysis store.
 <<Commands: cmd observable: TBP>>=
   procedure :: execute => cmd_observable_execute
 <<Commands: procedures>>=
   subroutine cmd_observable_execute (cmd, global)
     class(cmd_observable_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(graph_options_t) :: graph_options
     type(string_t) :: label, unit
     var_list => cmd%local%get_var_list_ptr ()
     label = var_list%get_sval (var_str ("$obs_label"))
     unit = var_list%get_sval (var_str ("$obs_unit"))
     call graph_options_init (graph_options)
     call set_graph_options (graph_options, var_list)
     call analysis_init_observable (cmd%id, label, unit, graph_options)
   end subroutine cmd_observable_execute
 
 @ %def cmd_observable_execute
 @
 \subsubsection{Histograms}
 Declare a histogram.  At minimum, we have to set lower and upper bound
 and bin width.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_histogram_t
      private
      type(string_t) :: id
      type(parse_node_t), pointer :: pn_lower_bound => null ()
      type(parse_node_t), pointer :: pn_upper_bound => null ()
      type(parse_node_t), pointer :: pn_bin_width => null ()
    contains
    <<Commands: cmd histogram: TBP>>
   end type cmd_histogram_t
 
 @ %def cmd_histogram_t
 @ Output.  Just print the ID.
 <<Commands: cmd histogram: TBP>>=
   procedure :: write => cmd_histogram_write
 <<Commands: procedures>>=
   subroutine cmd_histogram_write (cmd, unit, indent)
     class(cmd_histogram_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,A)")  "histogram: ", char (cmd%id)
   end subroutine cmd_histogram_write
 
 @ %def cmd_histogram_write
 @ Compile.  Record the histogram ID and initialize lower, upper bound
 and bin width.
 <<Commands: cmd histogram: TBP>>=
   procedure :: compile => cmd_histogram_compile
 <<Commands: procedures>>=
   subroutine cmd_histogram_compile (cmd, global)
     class(cmd_histogram_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_tag, pn_args, pn_arg1, pn_arg2, pn_arg3
     character(*), parameter :: e_illegal_use = &
        "illegal usage of 'histogram': insufficient number of arguments"
     pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
     pn_args => parse_node_get_next_ptr (pn_tag)
     if (associated (pn_args)) then
        pn_arg1 => parse_node_get_sub_ptr (pn_args)
        if (.not. associated (pn_arg1)) call msg_fatal (e_illegal_use)
        pn_arg2 => parse_node_get_next_ptr (pn_arg1)
        if (.not. associated (pn_arg2)) call msg_fatal (e_illegal_use)
        pn_arg3 => parse_node_get_next_ptr (pn_arg2)
        cmd%pn_opt => parse_node_get_next_ptr (pn_args)
     end if
     call cmd%compile_options (global)
     select case (char (parse_node_get_rule_key (pn_tag)))
     case ("analysis_id")
        cmd%id = parse_node_get_string (pn_tag)
     case default
        call msg_bug ("histogram: name expression not implemented (yet)")
     end select
     cmd%pn_lower_bound => pn_arg1
     cmd%pn_upper_bound => pn_arg2
     cmd%pn_bin_width => pn_arg3
   end subroutine cmd_histogram_compile
 
 @ %def cmd_histogram_compile
 @ Command execution.  This declares the histogram and allocates it in
 the analysis store.
 <<Commands: cmd histogram: TBP>>=
   procedure :: execute => cmd_histogram_execute
 <<Commands: procedures>>=
   subroutine cmd_histogram_execute (cmd, global)
     class(cmd_histogram_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     real(default) :: lower_bound, upper_bound, bin_width
     integer :: bin_number
     logical :: bin_width_is_used, normalize_bins
     type(string_t) :: obs_label, obs_unit
     type(graph_options_t) :: graph_options
     type(drawing_options_t) :: drawing_options
 
     var_list => cmd%local%get_var_list_ptr ()
     lower_bound = eval_real (cmd%pn_lower_bound, var_list)
     upper_bound = eval_real (cmd%pn_upper_bound, var_list)
     if (associated (cmd%pn_bin_width)) then
        bin_width = eval_real (cmd%pn_bin_width, var_list)
        bin_width_is_used = .true.
     else if (var_list%is_known (var_str ("n_bins"))) then
        bin_number = &
             var_list%get_ival (var_str ("n_bins"))
        bin_width_is_used = .false.
     else
        call msg_error ("Cmd '" // char (cmd%id) // &
             "': neither bin width nor number is defined")
     end if
     normalize_bins = &
          var_list%get_lval (var_str ("?normalize_bins"))
     obs_label = &
          var_list%get_sval (var_str ("$obs_label"))
     obs_unit = &
          var_list%get_sval (var_str ("$obs_unit"))
 
     call graph_options_init (graph_options)
     call set_graph_options (graph_options, var_list)
     call drawing_options_init_histogram (drawing_options)
     call set_drawing_options (drawing_options, var_list)
 
     if (bin_width_is_used) then
        call analysis_init_histogram &
             (cmd%id, lower_bound, upper_bound, bin_width, &
              normalize_bins, &
              obs_label, obs_unit, &
              graph_options, drawing_options)
     else
        call analysis_init_histogram &
             (cmd%id, lower_bound, upper_bound, bin_number, &
              normalize_bins, &
              obs_label, obs_unit, &
              graph_options, drawing_options)
     end if
   end subroutine cmd_histogram_execute
 
 @ %def cmd_histogram_execute
 @ Set the graph options from a variable list.
 <<Commands: procedures>>=
   subroutine set_graph_options (gro, var_list)
     type(graph_options_t), intent(inout) :: gro
     type(var_list_t), intent(in) :: var_list
     call graph_options_set (gro, title = &
          var_list%get_sval (var_str ("$title")))
     call graph_options_set (gro, description = &
          var_list%get_sval (var_str ("$description")))
     call graph_options_set (gro, x_label = &
          var_list%get_sval (var_str ("$x_label")))
     call graph_options_set (gro, y_label = &
          var_list%get_sval (var_str ("$y_label")))
     call graph_options_set (gro, width_mm = &
          var_list%get_ival (var_str ("graph_width_mm")))
     call graph_options_set (gro, height_mm = &
          var_list%get_ival (var_str ("graph_height_mm")))
     call graph_options_set (gro, x_log = &
          var_list%get_lval (var_str ("?x_log")))
     call graph_options_set (gro, y_log = &
          var_list%get_lval (var_str ("?y_log")))
     if (var_list%is_known (var_str ("x_min"))) &
          call graph_options_set (gro, x_min = &
          var_list%get_rval (var_str ("x_min")))
     if (var_list%is_known (var_str ("x_max"))) &
          call graph_options_set (gro, x_max = &
          var_list%get_rval (var_str ("x_max")))
     if (var_list%is_known (var_str ("y_min"))) &
          call graph_options_set (gro, y_min = &
          var_list%get_rval (var_str ("y_min")))
     if (var_list%is_known (var_str ("y_max"))) &
          call graph_options_set (gro, y_max = &
          var_list%get_rval (var_str ("y_max")))
     call graph_options_set (gro, gmlcode_bg = &
          var_list%get_sval (var_str ("$gmlcode_bg")))
     call graph_options_set (gro, gmlcode_fg = &
          var_list%get_sval (var_str ("$gmlcode_fg")))
   end subroutine set_graph_options
 
 @ %def set_graph_options
 @ Set the drawing options from a variable list.
 <<Commands: procedures>>=
   subroutine set_drawing_options (dro, var_list)
     type(drawing_options_t), intent(inout) :: dro
     type(var_list_t), intent(in) :: var_list
     if (var_list%is_known (var_str ("?draw_histogram"))) then
        if (var_list%get_lval (var_str ("?draw_histogram"))) then
           call drawing_options_set (dro, with_hbars = .true.)
        else
           call drawing_options_set (dro, with_hbars = .false., &
                with_base = .false., fill = .false., piecewise = .false.)
        end if
     end if
     if (var_list%is_known (var_str ("?draw_base"))) then
        if (var_list%get_lval (var_str ("?draw_base"))) then
           call drawing_options_set (dro, with_base = .true.)
        else
           call drawing_options_set (dro, with_base = .false., fill = .false.)
        end if
     end if
     if (var_list%is_known (var_str ("?draw_piecewise"))) then
        if (var_list%get_lval (var_str ("?draw_piecewise"))) then
           call drawing_options_set (dro, piecewise = .true.)
        else
           call drawing_options_set (dro, piecewise = .false.)
        end if
     end if
     if (var_list%is_known (var_str ("?fill_curve"))) then
        if (var_list%get_lval (var_str ("?fill_curve"))) then
           call drawing_options_set (dro, fill = .true., with_base = .true.)
        else
           call drawing_options_set (dro, fill = .false.)
        end if
     end if
     if (var_list%is_known (var_str ("?draw_curve"))) then
        if (var_list%get_lval (var_str ("?draw_curve"))) then
           call drawing_options_set (dro, draw = .true.)
        else
           call drawing_options_set (dro, draw = .false.)
        end if
     end if
     if (var_list%is_known (var_str ("?draw_errors"))) then
        if (var_list%get_lval (var_str ("?draw_errors"))) then
           call drawing_options_set (dro, err = .true.)
        else
           call drawing_options_set (dro, err = .false.)
        end if
     end if
     if (var_list%is_known (var_str ("?draw_symbols"))) then
        if (var_list%get_lval (var_str ("?draw_symbols"))) then
           call drawing_options_set (dro, symbols = .true.)
        else
           call drawing_options_set (dro, symbols = .false.)
        end if
     end if
     if (var_list%is_known (var_str ("$fill_options"))) then
        call drawing_options_set (dro, fill_options = &
             var_list%get_sval (var_str ("$fill_options")))
     end if
     if (var_list%is_known (var_str ("$draw_options"))) then
        call drawing_options_set (dro, draw_options = &
             var_list%get_sval (var_str ("$draw_options")))
     end if
     if (var_list%is_known (var_str ("$err_options"))) then
        call drawing_options_set (dro, err_options = &
             var_list%get_sval (var_str ("$err_options")))
     end if
     if (var_list%is_known (var_str ("$symbol"))) then
        call drawing_options_set (dro, symbol = &
             var_list%get_sval (var_str ("$symbol")))
     end if
     if (var_list%is_known (var_str ("$gmlcode_bg"))) then
        call drawing_options_set (dro, gmlcode_bg = &
             var_list%get_sval (var_str ("$gmlcode_bg")))
     end if
     if (var_list%is_known (var_str ("$gmlcode_fg"))) then
        call drawing_options_set (dro, gmlcode_fg = &
             var_list%get_sval (var_str ("$gmlcode_fg")))
     end if
   end subroutine set_drawing_options
 
 @ %def set_drawing_options
 @
 \subsubsection{Plots}
 Declare a plot.  No mandatory arguments, just options.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_plot_t
      private
      type(string_t) :: id
    contains
    <<Commands: cmd plot: TBP>>
   end type cmd_plot_t
 
 @ %def cmd_plot_t
 @ Output.  Just print the ID.
 <<Commands: cmd plot: TBP>>=
   procedure :: write => cmd_plot_write
 <<Commands: procedures>>=
   subroutine cmd_plot_write (cmd, unit, indent)
     class(cmd_plot_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,A)")  "plot: ", char (cmd%id)
   end subroutine cmd_plot_write
 
 @ %def cmd_plot_write
 @ Compile.  Record the plot ID and initialize lower, upper bound
 and bin width.
 <<Commands: cmd plot: TBP>>=
   procedure :: compile => cmd_plot_compile
 <<Commands: procedures>>=
   subroutine cmd_plot_compile (cmd, global)
     class(cmd_plot_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_tag
     pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
     cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
     call cmd%init (pn_tag, global)
   end subroutine cmd_plot_compile
 
 @ %def cmd_plot_compile
 @ This init routine is separated because it is reused below for graph
 initialization.
 <<Commands: cmd plot: TBP>>=
   procedure :: init => cmd_plot_init
 <<Commands: procedures>>=
   subroutine cmd_plot_init (plot, pn_tag, global)
     class(cmd_plot_t), intent(inout) :: plot
     type(parse_node_t), intent(in), pointer :: pn_tag
     type(rt_data_t), intent(inout), target :: global
     call plot%compile_options (global)
     select case (char (parse_node_get_rule_key (pn_tag)))
     case ("analysis_id")
        plot%id = parse_node_get_string (pn_tag)
     case default
        call msg_bug ("plot: name expression not implemented (yet)")
     end select
   end subroutine cmd_plot_init
 
 @ %def cmd_plot_init
 @ Command execution.  This declares the plot and allocates it in
 the analysis store.
 <<Commands: cmd plot: TBP>>=
   procedure :: execute => cmd_plot_execute
 <<Commands: procedures>>=
   subroutine cmd_plot_execute (cmd, global)
     class(cmd_plot_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(graph_options_t) :: graph_options
     type(drawing_options_t) :: drawing_options
 
     var_list => cmd%local%get_var_list_ptr ()
     call graph_options_init (graph_options)
     call set_graph_options (graph_options, var_list)
     call drawing_options_init_plot (drawing_options)
     call set_drawing_options (drawing_options, var_list)
 
     call analysis_init_plot (cmd%id, graph_options, drawing_options)
   end subroutine cmd_plot_execute
 
 @ %def cmd_plot_execute
 @
 \subsubsection{Graphs}
 Declare a graph.  The graph is defined in terms of its contents.  Both the
 graph and its contents may carry options.
 
 The graph object contains its own ID as well as the IDs of its elements.  For
 the elements, we reuse the [[cmd_plot_t]] defined above.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_graph_t
      private
      type(string_t) :: id
      integer :: n_elements = 0
      type(cmd_plot_t), dimension(:), allocatable :: el
      type(string_t), dimension(:), allocatable :: element_id
    contains
    <<Commands: cmd graph: TBP>>
   end type cmd_graph_t
 
 @ %def cmd_graph_t
 @ Output.  Just print the ID.
 <<Commands: cmd graph: TBP>>=
   procedure :: write => cmd_graph_write
 <<Commands: procedures>>=
   subroutine cmd_graph_write (cmd, unit, indent)
     class(cmd_graph_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,A,A,I0,A)")  "graph: ", char (cmd%id), &
          " (", cmd%n_elements, " entries)"
   end subroutine cmd_graph_write
 
 @ %def cmd_graph_write
 @ Compile.  Record the graph ID and initialize lower, upper bound
 and bin width.  For compiling the graph element syntax, we use part of the
 [[cmd_plot_t]] compiler.
 
 Note: currently, we do not respect options, therefore just IDs on the RHS.
 <<Commands: cmd graph: TBP>>=
   procedure :: compile => cmd_graph_compile
 <<Commands: procedures>>=
   subroutine cmd_graph_compile (cmd, global)
     class(cmd_graph_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_term, pn_tag, pn_def, pn_app
     integer :: i
 
     pn_term => parse_node_get_sub_ptr (cmd%pn, 2)
     pn_tag => parse_node_get_sub_ptr (pn_term)
     cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
     call cmd%compile_options (global)
     select case (char (parse_node_get_rule_key (pn_tag)))
     case ("analysis_id")
        cmd%id = parse_node_get_string (pn_tag)
     case default
        call msg_bug ("graph: name expression not implemented (yet)")
     end select
     pn_def => parse_node_get_next_ptr (pn_term, 2)
     cmd%n_elements = parse_node_get_n_sub (pn_def)
     allocate (cmd%element_id (cmd%n_elements))
     allocate (cmd%el (cmd%n_elements))
     pn_term => parse_node_get_sub_ptr (pn_def)
     pn_tag => parse_node_get_sub_ptr (pn_term)
     cmd%el(1)%pn_opt => parse_node_get_next_ptr (pn_tag)
     call cmd%el(1)%init (pn_tag, global)
     cmd%element_id(1) = parse_node_get_string (pn_tag)
     pn_app => parse_node_get_next_ptr (pn_term)
     do i = 2, cmd%n_elements
        pn_term => parse_node_get_sub_ptr (pn_app, 2)
        pn_tag => parse_node_get_sub_ptr (pn_term)
        cmd%el(i)%pn_opt => parse_node_get_next_ptr (pn_tag)
        call cmd%el(i)%init (pn_tag, global)
        cmd%element_id(i) = parse_node_get_string (pn_tag)
        pn_app => parse_node_get_next_ptr (pn_app)
     end do
 
   end subroutine cmd_graph_compile
 
 @ %def cmd_graph_compile
 @ Command execution.  This declares the graph, allocates it in
 the analysis store, and copies the graph elements.
 
 For the graph, we set graph and default drawing options.  For the elements, we
 reset individual drawing options.
 
 This accesses internals of the contained elements of type [[cmd_plot_t]], see
 above.  We might disentangle such an interdependency when this code is
 rewritten using proper type extension.
 <<Commands: cmd graph: TBP>>=
   procedure :: execute => cmd_graph_execute
 <<Commands: procedures>>=
   subroutine cmd_graph_execute (cmd, global)
     class(cmd_graph_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(graph_options_t) :: graph_options
     type(drawing_options_t) :: drawing_options
     integer :: i, type
 
     var_list => cmd%local%get_var_list_ptr ()
     call graph_options_init (graph_options)
     call set_graph_options (graph_options, var_list)
     call analysis_init_graph (cmd%id, cmd%n_elements, graph_options)
 
     do i = 1, cmd%n_elements
        if (associated (cmd%el(i)%options)) then
           call cmd%el(i)%options%execute (cmd%el(i)%local)
        end if
        type = analysis_store_get_object_type (cmd%element_id(i))
        select case (type)
        case (AN_HISTOGRAM)
           call drawing_options_init_histogram (drawing_options)
        case (AN_PLOT)
           call drawing_options_init_plot (drawing_options)
        end select
        call set_drawing_options (drawing_options, var_list)
        if (associated (cmd%el(i)%options)) then
           call set_drawing_options (drawing_options, cmd%el(i)%local%var_list)
        end if
        call analysis_fill_graph (cmd%id, i, cmd%element_id(i), drawing_options)
     end do
   end subroutine cmd_graph_execute
 
 @ %def cmd_graph_execute
 @
 \subsubsection{Analysis}
 Hold the analysis ID either as a string or as an expression:
 <<Commands: types>>=
   type :: analysis_id_t
     type(string_t) :: tag
     type(parse_node_t), pointer :: pn_sexpr => null ()
   end type analysis_id_t
 
 @ %def analysis_id_t
 @ Define the analysis expression.  We store the parse tree for the
 right-hand side instead of compiling it.  Compilation is deferred to
 the process environment where the analysis expression is used.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_analysis_t
      private
      type(parse_node_t), pointer :: pn_lexpr => null ()
    contains
    <<Commands: cmd analysis: TBP>>
   end type cmd_analysis_t
 
 @ %def cmd_analysis_t
 @ Output.  Print just a message that analysis has been defined.
 <<Commands: cmd analysis: TBP>>=
   procedure :: write => cmd_analysis_write
 <<Commands: procedures>>=
   subroutine cmd_analysis_write (cmd, unit, indent)
     class(cmd_analysis_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "analysis: [defined]"
   end subroutine cmd_analysis_write
 
 @ %def cmd_analysis_write
 @ Compile.  Simply store the parse (sub)tree.
 <<Commands: cmd analysis: TBP>>=
   procedure :: compile => cmd_analysis_compile
 <<Commands: procedures>>=
   subroutine cmd_analysis_compile (cmd, global)
     class(cmd_analysis_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3)
   end subroutine cmd_analysis_compile
 
 @ %def cmd_analysis_compile
 @ Instead of evaluating the cut expression, link the parse tree to the
 global data set, such that it is compiled and executed in the
 appropriate process context.
 <<Commands: cmd analysis: TBP>>=
   procedure :: execute => cmd_analysis_execute
 <<Commands: procedures>>=
   subroutine cmd_analysis_execute (cmd, global)
     class(cmd_analysis_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     global%pn%analysis_lexpr => cmd%pn_lexpr
   end subroutine cmd_analysis_execute
 
 @ %def cmd_analysis_execute
 @
 \subsubsection{Write histograms and plots}
 The data type encapsulating the command:
 <<Commands: types>>=
   type, extends (command_t) :: cmd_write_analysis_t
      private
      type(analysis_id_t), dimension(:), allocatable :: id
      type(string_t), dimension(:), allocatable :: tag
    contains
    <<Commands: cmd write analysis: TBP>>
   end type cmd_write_analysis_t
 
 @ %def analysis_id_t
 @ %def cmd_write_analysis_t
 @ Output.  Just the keyword.
 <<Commands: cmd write analysis: TBP>>=
   procedure :: write => cmd_write_analysis_write
 <<Commands: procedures>>=
   subroutine cmd_write_analysis_write (cmd, unit, indent)
     class(cmd_write_analysis_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "write_analysis"
   end subroutine cmd_write_analysis_write
 
 @ %def cmd_write_analysis_write
 @ Compile.
 <<Commands: cmd write analysis: TBP>>=
   procedure :: compile => cmd_write_analysis_compile
 <<Commands: procedures>>=
   subroutine cmd_write_analysis_compile (cmd, global)
     class(cmd_write_analysis_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_clause, pn_args, pn_id
     integer :: n, i
     pn_clause => parse_node_get_sub_ptr (cmd%pn)
     pn_args => parse_node_get_sub_ptr (pn_clause, 2)
     cmd%pn_opt => parse_node_get_next_ptr (pn_clause)
     call cmd%compile_options (global)
     if (associated (pn_args)) then
        n = parse_node_get_n_sub (pn_args)
        allocate (cmd%id (n))
        do i = 1, n
            pn_id => parse_node_get_sub_ptr (pn_args, i)
            if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then
               cmd%id(i)%tag = parse_node_get_string (pn_id)
            else
               cmd%id(i)%pn_sexpr => pn_id
            end if
        end do
     else
        allocate (cmd%id (0))
     end if
   end subroutine cmd_write_analysis_compile
 
 @ %def cmd_write_analysis_compile
 @ The output format for real data values:
 <<Commands: parameters>>=
   character(*), parameter, public :: &
        DEFAULT_ANALYSIS_FILENAME = "whizard_analysis.dat"
   character(len=1), dimension(2), parameter, public :: &
        FORBIDDEN_ENDINGS1 = [ "o", "a" ]
   character(len=2), dimension(6), parameter, public :: &
        FORBIDDEN_ENDINGS2 = [ "mp", "ps", "vg", "pg", "lo", "la" ]
   character(len=3), dimension(18), parameter, public :: &
        FORBIDDEN_ENDINGS3 = [ "aux", "dvi", "evt", "evx", "f03", "f90", &
           "f95", "log", "ltp", "mpx", "olc", "olp", "pdf", "phs", "sin", &
           "tex", "vg2", "vgx" ]
 
 @ %def DEFAULT_ANALYSIS_FILENAME
 @ %def FORBIDDEN_ENDINGS1
 @ %def FORBIDDEN_ENDINGS2
 @ %def FORBIDDEN_ENDINGS3
 @ As this contains a lot of similar code to [[cmd_compile_analysis_execute]]
 we outsource the main code to a subroutine.
 <<Commands: cmd write analysis: TBP>>=
   procedure :: execute => cmd_write_analysis_execute
 <<Commands: procedures>>=
   subroutine cmd_write_analysis_execute (cmd, global)
     class(cmd_write_analysis_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     var_list => cmd%local%get_var_list_ptr ()
     call write_analysis_wrap (var_list, global%out_files, &
          cmd%id, tag = cmd%tag)
   end subroutine cmd_write_analysis_execute
 
 @ %def cmd_write_analysis_execute
 @ If the [[data_file]] optional argument is present, this is
 called from [[cmd_compile_analysis_execute]], which needs the file name for
 further processing, and requires the default format.  For the moment,
 parameters and macros for custom data processing are disabled.
 <<Commands: procedures>>=
   subroutine write_analysis_wrap (var_list, out_files, id, tag, data_file)
     type(var_list_t), intent(inout), target :: var_list
     type(file_list_t), intent(inout), target :: out_files
     type(analysis_id_t), dimension(:), intent(in), target :: id
     type(string_t), dimension(:), allocatable, intent(out) :: tag
     type(string_t), intent(out), optional :: data_file
     type(string_t) :: defaultfile, file
     integer :: i
     logical :: keep_open !, custom, header, columns
     type(string_t) :: extension !, comment_prefix, separator
 !!! JRR: WK please check (#542)
 !     integer :: type
 !     type(ifile_t) :: ifile
     logical :: one_file !, has_writer
 !     type(analysis_iterator_t) :: iterator
 !     type(rt_data_t), target :: sandbox
 !     type(command_list_t) :: writer
     defaultfile = var_list%get_sval (var_str ("$out_file"))
     if (present (data_file)) then
        if (defaultfile == "" .or. defaultfile == ".") then
           defaultfile = DEFAULT_ANALYSIS_FILENAME
        else
           if (scan (".", defaultfile) > 0) then
              call split (defaultfile, extension, ".", back=.true.)
              if (any (lower_case (char(extension)) == FORBIDDEN_ENDINGS1) .or. &
                  any (lower_case (char(extension)) == FORBIDDEN_ENDINGS2) .or. &
                  any (lower_case (char(extension)) == FORBIDDEN_ENDINGS3)) &
                  call msg_fatal ("The ending " // char(extension) // &
                  " is internal and not allowed as data file.")
              if (extension /= "") then
                 if (defaultfile /= "") then
                    defaultfile = defaultfile // "." // extension
                 else
                    defaultfile = "whizard_analysis." // extension
                 end if
              else
                 defaultfile = defaultfile // ".dat"
              endif
           else
              defaultfile = defaultfile // ".dat"
           end if
        end if
        data_file = defaultfile
     end if
     one_file = defaultfile /= ""
     if (one_file) then
        file = defaultfile
        keep_open = file_list_is_open (out_files, file, &
             action = "write")
        if (keep_open) then
           if (present (data_file)) then
              call msg_fatal ("Compiling analysis: File '" &
                   // char (data_file) &
                    // "' can't be used, it is already open.")
           else
              call msg_message ("Appending analysis data to file '" &
                   // char (file) // "'")
           end if
        else
           call file_list_open (out_files, file, &
                action = "write", status = "replace", position = "asis")
           call msg_message ("Writing analysis data to file '" &
                // char (file) // "'")
        end if
     end if
 
 !!! JRR: WK please check. Custom data output. Ticket #542
 !     if (present (data_file)) then
 !        custom = .false.
 !     else
 !        custom = var_list%get_lval (&
 !            var_str ("?out_custom"))
 !     end if
 !     comment_prefix = var_list%get_sval (&
 !          var_str ("$out_comment"))
 !     header = var_list%get_lval (&
 !          var_str ("?out_header"))
 !     write_yerr = var_list%get_lval (&
 !          var_str ("?out_yerr"))
 !     write_xerr = var_list%get_lval (&
 !          var_str ("?out_xerr"))
 
     call get_analysis_tags (tag, id, var_list)
     do i = 1, size (tag)
        call file_list_write_analysis &
             (out_files, file, tag(i))
     end do
     if (one_file .and. .not. keep_open) then
        call file_list_close (out_files, file)
     end if
 
   contains
 
     subroutine get_analysis_tags (analysis_tag, id, var_list)
       type(string_t), dimension(:), intent(out), allocatable :: analysis_tag
       type(analysis_id_t), dimension(:), intent(in) :: id
       type(var_list_t), intent(in), target :: var_list
       if (size (id) /= 0) then
          allocate (analysis_tag (size (id)))
          do i = 1, size (id)
             if (associated (id(i)%pn_sexpr)) then
                analysis_tag(i) = eval_string (id(i)%pn_sexpr, var_list)
             else
                analysis_tag(i) = id(i)%tag
             end if
          end do
       else
          call analysis_store_get_ids (tag)
       end if
     end subroutine get_analysis_tags
 
   end subroutine write_analysis_wrap
 
 @ %def write_analysis_wrap
 \subsubsection{Compile analysis results}
 This command writes files in a form suitable for GAMELAN and executes the
 appropriate commands to compile them.  The first part is identical to
 [[cmd_write_analysis]].
 <<Commands: types>>=
   type, extends (command_t) :: cmd_compile_analysis_t
      private
      type(analysis_id_t), dimension(:), allocatable :: id
      type(string_t), dimension(:), allocatable :: tag
    contains
    <<Commands: cmd compile analysis: TBP>>
   end type cmd_compile_analysis_t
 
 @ %def cmd_compile_analysis_t
 @ Output.  Just the keyword.
 <<Commands: cmd compile analysis: TBP>>=
   procedure :: write => cmd_compile_analysis_write
 <<Commands: procedures>>=
   subroutine cmd_compile_analysis_write (cmd, unit, indent)
     class(cmd_compile_analysis_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "compile_analysis"
   end subroutine cmd_compile_analysis_write
 
 @ %def cmd_compile_analysis_write
 @ Compile.
 <<Commands: cmd compile analysis: TBP>>=
   procedure :: compile => cmd_compile_analysis_compile
 <<Commands: procedures>>=
   subroutine cmd_compile_analysis_compile (cmd, global)
     class(cmd_compile_analysis_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_clause, pn_args, pn_id
     integer :: n, i
     pn_clause => parse_node_get_sub_ptr (cmd%pn)
     pn_args => parse_node_get_sub_ptr (pn_clause, 2)
     cmd%pn_opt => parse_node_get_next_ptr (pn_clause)
     call cmd%compile_options (global)
     if (associated (pn_args)) then
        n = parse_node_get_n_sub (pn_args)
        allocate (cmd%id (n))
        do i = 1, n
            pn_id => parse_node_get_sub_ptr (pn_args, i)
            if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then
               cmd%id(i)%tag = parse_node_get_string (pn_id)
            else
               cmd%id(i)%pn_sexpr => pn_id
            end if
        end do
     else
        allocate (cmd%id (0))
     end if
   end subroutine cmd_compile_analysis_compile
 
 @ %def cmd_compile_analysis_compile
 @ First write the analysis data to file, then write a GAMELAN driver and
 produce MetaPost and \TeX\ output.
 <<Commands: cmd compile analysis: TBP>>=
   procedure :: execute => cmd_compile_analysis_execute
 <<Commands: procedures>>=
   subroutine cmd_compile_analysis_execute (cmd, global)
     class(cmd_compile_analysis_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(string_t) :: file, basename, extension, driver_file, &
          makefile
     integer :: u_driver, u_makefile
     logical :: has_gmlcode, only_file
     var_list => cmd%local%get_var_list_ptr ()
     call write_analysis_wrap (var_list, &
          global%out_files, cmd%id, tag = cmd%tag, &
             data_file = file)
     basename = file
     if (scan (".", basename) > 0) then
       call split (basename, extension, ".", back=.true.)
     else
       extension = ""
     end if
     driver_file = basename // ".tex"
     makefile = basename // "_ana.makefile"
     u_driver = free_unit ()
     open (unit=u_driver, file=char(driver_file), &
           action="write", status="replace")
     if (allocated (cmd%tag)) then
        call analysis_write_driver (file, cmd%tag, unit=u_driver)
        has_gmlcode = analysis_has_plots (cmd%tag)
     else
        call analysis_write_driver (file, unit=u_driver)
        has_gmlcode = analysis_has_plots ()
     end if
     close (u_driver)
     u_makefile = free_unit ()
     open (unit=u_makefile, file=char(makefile), &
          action="write", status="replace")
     call analysis_write_makefile (basename, u_makefile, &
          has_gmlcode, global%os_data)
     close (u_makefile)
     call msg_message ("Compiling analysis results display in '" &
          // char (driver_file) // "'")
     call msg_message ("Providing analysis steering makefile '" &
          // char (makefile) // "'")
     only_file = global%var_list%get_lval &
          (var_str ("?analysis_file_only"))
     if (.not. only_file)  call analysis_compile_tex &
          (basename, has_gmlcode, global%os_data)
   end subroutine cmd_compile_analysis_execute
 
 @ %def cmd_compile_analysis_execute
 @
 \subsection{User-controlled output to data files}
 
 \subsubsection{Open file (output)}
 Open a file for output.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_open_out_t
      private
      type(parse_node_t), pointer :: file_expr => null ()
    contains
    <<Commands: cmd open out: TBP>>
   end type cmd_open_out_t
 
 @ %def cmd_open_out
 @ Finalizer for the embedded eval tree.
 <<Commands: procedures>>=
   subroutine cmd_open_out_final (object)
     class(cmd_open_out_t), intent(inout) :: object
   end subroutine cmd_open_out_final
 
 @ %def cmd_open_out_final
 @ Output (trivial here).
 <<Commands: cmd open out: TBP>>=
   procedure :: write => cmd_open_out_write
 <<Commands: procedures>>=
   subroutine cmd_open_out_write (cmd, unit, indent)
     class(cmd_open_out_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "open_out: <filename>"
   end subroutine cmd_open_out_write
 
 @ %def cmd_open_out_write
 @ Compile: create an eval tree for the filename expression.
 <<Commands: cmd open out: TBP>>=
   procedure :: compile => cmd_open_out_compile
 <<Commands: procedures>>=
   subroutine cmd_open_out_compile (cmd, global)
     class(cmd_open_out_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     cmd%file_expr => parse_node_get_sub_ptr (cmd%pn, 2)
     if (associated (cmd%file_expr)) then
        cmd%pn_opt => parse_node_get_next_ptr (cmd%file_expr)
     end if
     call cmd%compile_options (global)
   end subroutine cmd_open_out_compile
 
 @ %def cmd_open_out_compile
 @ Execute: append the file to the global list of open files.
 <<Commands: cmd open out: TBP>>=
   procedure :: execute => cmd_open_out_execute
 <<Commands: procedures>>=
   subroutine cmd_open_out_execute (cmd, global)
     class(cmd_open_out_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(eval_tree_t) :: file_expr
     type(string_t) :: file
     var_list => cmd%local%get_var_list_ptr ()
     call file_expr%init_sexpr (cmd%file_expr, var_list)
     call file_expr%evaluate ()
     if (file_expr%is_known ()) then
        file = file_expr%get_string ()
        call file_list_open (global%out_files, file, &
             action = "write", status = "replace", position = "asis")
     else
        call msg_fatal ("open_out: file name argument evaluates to unknown")
     end if
     call file_expr%final ()
   end subroutine cmd_open_out_execute
 
 @ %def cmd_open_out_execute
 
 \subsubsection{Open file (output)}
 Close an output file.  Except for the [[execute]] method, everything is
 analogous to the open command, so we can just inherit.
 <<Commands: types>>=
   type, extends (cmd_open_out_t) :: cmd_close_out_t
      private
    contains
    <<Commands: cmd close out: TBP>>
   end type cmd_close_out_t
 
 @ %def cmd_close_out
 @ Execute: remove the file from the global list of output files.
 <<Commands: cmd close out: TBP>>=
   procedure :: execute => cmd_close_out_execute
 <<Commands: procedures>>=
   subroutine cmd_close_out_execute (cmd, global)
     class(cmd_close_out_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(eval_tree_t) :: file_expr
     type(string_t) :: file
     var_list => cmd%local%var_list
     call file_expr%init_sexpr (cmd%file_expr, var_list)
     call file_expr%evaluate ()
     if (file_expr%is_known ()) then
        file = file_expr%get_string ()
        call file_list_close (global%out_files, file)
     else
        call msg_fatal ("close_out: file name argument evaluates to unknown")
     end if
     call file_expr%final ()
   end subroutine cmd_close_out_execute
 
 @ %def cmd_close_out_execute
 @
 \subsection{Print custom-formatted values}
 <<Commands: types>>=
   type, extends (command_t) :: cmd_printf_t
      private
      type(parse_node_t), pointer :: sexpr => null ()
      type(parse_node_t), pointer :: sprintf_fun => null ()
      type(parse_node_t), pointer :: sprintf_clause => null ()
      type(parse_node_t), pointer :: sprintf => null ()
    contains
    <<Commands: cmd printf: TBP>>
   end type cmd_printf_t
 
 @ %def cmd_printf_t
 @ Finalize.
 <<Commands: cmd printf: TBP>>=
   procedure :: final => cmd_printf_final
 <<Commands: procedures>>=
   subroutine cmd_printf_final (cmd)
     class(cmd_printf_t), intent(inout) :: cmd
     call parse_node_final (cmd%sexpr, recursive = .false.)
     deallocate (cmd%sexpr)
     call parse_node_final (cmd%sprintf_fun, recursive = .false.)
     deallocate (cmd%sprintf_fun)
     call parse_node_final (cmd%sprintf_clause, recursive = .false.)
     deallocate (cmd%sprintf_clause)
     call parse_node_final (cmd%sprintf, recursive = .false.)
     deallocate (cmd%sprintf)
   end subroutine cmd_printf_final
 
 @ %def cmd_printf_final
 @ Output.  Do not print the parse tree, since this may get cluttered.
 Just a message that cuts have been defined.
 <<Commands: cmd printf: TBP>>=
   procedure :: write => cmd_printf_write
 <<Commands: procedures>>=
   subroutine cmd_printf_write (cmd, unit, indent)
     class(cmd_printf_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "printf:"
   end subroutine cmd_printf_write
 
 @ %def cmd_printf_write
 @ Compile.  We create a fake parse node (subtree) with a [[sprintf]] command
 with identical arguments which can then be handled by the corresponding
 evaluation procedure.
 <<Commands: cmd printf: TBP>>=
   procedure :: compile => cmd_printf_compile
 <<Commands: procedures>>=
   subroutine cmd_printf_compile (cmd, global)
     class(cmd_printf_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_args, pn_format
     pn_cmd => parse_node_get_sub_ptr (cmd%pn)
     pn_clause => parse_node_get_sub_ptr (pn_cmd)
     pn_format => parse_node_get_sub_ptr (pn_clause, 2)
     pn_args => parse_node_get_next_ptr (pn_clause)
     cmd%pn_opt => parse_node_get_next_ptr (pn_cmd)
     call cmd%compile_options (global)
     allocate (cmd%sexpr)
     call parse_node_create_branch (cmd%sexpr, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("sexpr")))
     allocate (cmd%sprintf_fun)
     call parse_node_create_branch (cmd%sprintf_fun, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_fun")))
     allocate (cmd%sprintf_clause)
     call parse_node_create_branch (cmd%sprintf_clause, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_clause")))
     allocate (cmd%sprintf)
     call parse_node_create_key (cmd%sprintf, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf")))
     call parse_node_append_sub (cmd%sprintf_clause, cmd%sprintf)
     call parse_node_append_sub (cmd%sprintf_clause, pn_format)
     call parse_node_freeze_branch (cmd%sprintf_clause)
     call parse_node_append_sub (cmd%sprintf_fun, cmd%sprintf_clause)
     if (associated (pn_args)) then
        call parse_node_append_sub (cmd%sprintf_fun, pn_args)
     end if
     call parse_node_freeze_branch (cmd%sprintf_fun)
     call parse_node_append_sub (cmd%sexpr, cmd%sprintf_fun)
     call parse_node_freeze_branch (cmd%sexpr)
   end subroutine cmd_printf_compile
 
 @ %def cmd_printf_compile
 @ Execute.  Evaluate the string (pretending this is a [[sprintf]] expression)
 and print it.
 <<Commands: cmd printf: TBP>>=
   procedure :: execute => cmd_printf_execute
 <<Commands: procedures>>=
   subroutine cmd_printf_execute (cmd, global)
     class(cmd_printf_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(string_t) :: string, file
     type(eval_tree_t) :: sprintf_expr
     logical :: advance
     var_list => cmd%local%get_var_list_ptr ()
     advance = var_list%get_lval (&
          var_str ("?out_advance"))
     file = var_list%get_sval (&
          var_str ("$out_file"))
     call sprintf_expr%init_sexpr (cmd%sexpr, var_list)
     call sprintf_expr%evaluate ()
     if (sprintf_expr%is_known ()) then
        string = sprintf_expr%get_string ()
        if (len (file) == 0) then
           call msg_result (char (string))
        else
           call file_list_write (global%out_files, file, string, advance)
        end if
     end if
   end subroutine cmd_printf_execute
 
 @ %def cmd_printf_execute
 @
 \subsubsection{Record data}
 The expression syntax already contains a [[record]] keyword; this evaluates to
 a logical which is always true, but it has the side-effect of recording data
 into analysis objects.  Here we define a command as an interface to this
 construct.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_record_t
      private
      type(parse_node_t), pointer :: pn_lexpr => null ()
    contains
    <<Commands: cmd record: TBP>>
   end type cmd_record_t
 
 @ %def cmd_record_t
 @ Output.  With the compile hack below, there is nothing of interest
 to print here.
 <<Commands: cmd record: TBP>>=
   procedure :: write => cmd_record_write
 <<Commands: procedures>>=
   subroutine cmd_record_write (cmd, unit, indent)
     class(cmd_record_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)")  "record"
   end subroutine cmd_record_write
 
 @ %def cmd_record_write
 @ Compile.  This is a hack which transforms the [[record]] command
 into a [[record]] expression, which we handle in the [[expressions]]
 module.
 <<Commands: cmd record: TBP>>=
   procedure :: compile => cmd_record_compile
 <<Commands: procedures>>=
   subroutine cmd_record_compile (cmd, global)
     class(cmd_record_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_lexpr, pn_lsinglet, pn_lterm, pn_record
     call parse_node_create_branch (pn_lexpr, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("lexpr")))
     call parse_node_create_branch (pn_lsinglet, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("lsinglet")))
     call parse_node_append_sub (pn_lexpr, pn_lsinglet)
     call parse_node_create_branch (pn_lterm, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("lterm")))
     call parse_node_append_sub (pn_lsinglet, pn_lterm)
     pn_record => parse_node_get_sub_ptr (cmd%pn)
     call parse_node_append_sub (pn_lterm, pn_record)
     cmd%pn_lexpr => pn_lexpr
   end subroutine cmd_record_compile
 
 @ %def cmd_record_compile
 @ Command execution.  Again, transfer this to the embedded expression
 and just forget the logical result.
 <<Commands: cmd record: TBP>>=
   procedure :: execute => cmd_record_execute
 <<Commands: procedures>>=
   subroutine cmd_record_execute (cmd, global)
     class(cmd_record_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     logical :: lval
     var_list => global%get_var_list_ptr ()
     lval = eval_log (cmd%pn_lexpr, var_list)
   end subroutine cmd_record_execute
 
 @ %def cmd_record_execute
 @
 \subsubsection{Unstable particles}
 Mark a particle as unstable.  For each unstable particle, we store a
 number of decay channels and compute their respective BRs.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_unstable_t
      private
      integer :: n_proc = 0
      type(string_t), dimension(:), allocatable :: process_id
      type(parse_node_t), pointer :: pn_prt_in => null ()
    contains
    <<Commands: cmd unstable: TBP>>
   end type cmd_unstable_t
 
 @ %def cmd_unstable_t
 @ Output: we know the process IDs.
 <<Commands: cmd unstable: TBP>>=
   procedure :: write => cmd_unstable_write
 <<Commands: procedures>>=
   subroutine cmd_unstable_write (cmd, unit, indent)
     class(cmd_unstable_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,1x,I0,1x,A)", advance="no")  &
          "unstable:", 1, "("
     do i = 1, cmd%n_proc
        if (i > 1)  write (u, "(A,1x)", advance="no")  ","
        write (u, "(A)", advance="no")  char (cmd%process_id(i))
     end do
     write (u, "(A)")  ")"
   end subroutine cmd_unstable_write
 
 @ %def cmd_unstable_write
 @ Compile.  Initiate an eval tree for the decaying particle and
 determine the decay channel process IDs.
 <<Commands: cmd unstable: TBP>>=
   procedure :: compile => cmd_unstable_compile
 <<Commands: procedures>>=
   subroutine cmd_unstable_compile (cmd, global)
     class(cmd_unstable_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_list, pn_proc
     integer :: i
     cmd%pn_prt_in => parse_node_get_sub_ptr (cmd%pn, 2)
     pn_list => parse_node_get_next_ptr (cmd%pn_prt_in)
     if (associated (pn_list)) then
        select case (char (parse_node_get_rule_key (pn_list)))
        case ("unstable_arg")
           cmd%n_proc = parse_node_get_n_sub (pn_list)
           cmd%pn_opt => parse_node_get_next_ptr (pn_list)
        case default
           cmd%n_proc = 0
           cmd%pn_opt => pn_list
           pn_list => null ()
        end select
     end if
     call cmd%compile_options (global)
     if (associated (pn_list)) then
        allocate (cmd%process_id (cmd%n_proc))
        pn_proc => parse_node_get_sub_ptr (pn_list)
        do i = 1, cmd%n_proc
           cmd%process_id(i) = parse_node_get_string (pn_proc)
           call cmd%local%process_stack%init_result_vars (cmd%process_id(i))
           pn_proc => parse_node_get_next_ptr (pn_proc)
        end do
     else
        allocate (cmd%process_id (0))
     end if
   end subroutine cmd_unstable_compile
 
 @ %def cmd_unstable_compile
 @ Command execution.  Evaluate the decaying particle and mark the decays in
 the current model object.
 <<Commands: cmd unstable: TBP>>=
   procedure :: execute => cmd_unstable_execute
 <<Commands: procedures>>=
   subroutine cmd_unstable_execute (cmd, global)
     class(cmd_unstable_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     logical :: auto_decays, auto_decays_radiative
     integer :: auto_decays_multiplicity
     logical :: isotropic_decay, diagonal_decay, polarized_decay
     integer :: decay_helicity
     type(pdg_array_t) :: pa_in
     integer :: pdg_in
     type(string_t) :: libname_cur, libname_dec
     type(string_t), dimension(:), allocatable :: auto_id, tmp_id
     integer :: n_proc_user
     integer :: i, u_tmp
     character(80) :: buffer
     var_list => cmd%local%get_var_list_ptr ()
     auto_decays = &
          var_list%get_lval (var_str ("?auto_decays"))
     if (auto_decays) then
        auto_decays_multiplicity = &
             var_list%get_ival (var_str ("auto_decays_multiplicity"))
        auto_decays_radiative = &
             var_list%get_lval (var_str ("?auto_decays_radiative"))
     end if
     isotropic_decay = &
          var_list%get_lval (var_str ("?isotropic_decay"))
     if (isotropic_decay) then
        diagonal_decay = .false.
        polarized_decay = .false.
     else
        diagonal_decay = &
             var_list%get_lval (var_str ("?diagonal_decay"))
        if (diagonal_decay) then
           polarized_decay = .false.
        else
           polarized_decay = &
                var_list%is_known (var_str ("decay_helicity"))
           if (polarized_decay) then
              decay_helicity = var_list%get_ival (var_str ("decay_helicity"))
           end if
        end if
     end if
     pa_in = eval_pdg_array (cmd%pn_prt_in, var_list)
     if (pdg_array_get_length (pa_in) /= 1) &
          call msg_fatal ("Unstable: decaying particle must be unique")
     pdg_in = pdg_array_get (pa_in, 1)
     n_proc_user = cmd%n_proc
     if (auto_decays) then
        call create_auto_decays (pdg_in, &
             auto_decays_multiplicity, auto_decays_radiative, &
             libname_dec, auto_id, cmd%local)
        allocate (tmp_id (cmd%n_proc + size (auto_id)))
        tmp_id(:cmd%n_proc) = cmd%process_id
        tmp_id(cmd%n_proc+1:) = auto_id
        call move_alloc (from = tmp_id, to = cmd%process_id)
        cmd%n_proc = size (cmd%process_id)
     end if
     libname_cur = cmd%local%prclib%get_name ()
     do i = 1, cmd%n_proc
        if (i == n_proc_user + 1) then
           call cmd%local%update_prclib &
                (cmd%local%prclib_stack%get_library_ptr (libname_dec))
        end if
        if (.not. global%process_stack%exists (cmd%process_id(i))) then
           call var_list%set_log &
                (var_str ("?decay_rest_frame"), .false., is_known = .true.)
           call integrate_process (cmd%process_id(i), cmd%local, global)
           call global%process_stack%fill_result_vars (cmd%process_id(i))
        end if
     end do
     call cmd%local%update_prclib &
          (cmd%local%prclib_stack%get_library_ptr (libname_cur))
     if (cmd%n_proc > 0) then
        if (polarized_decay) then
           call global%modify_particle (pdg_in, stable = .false., &
                decay = cmd%process_id, &
                isotropic_decay = .false., &
                diagonal_decay = .false., &
                decay_helicity = decay_helicity, &
                polarized = .false.)
        else
           call global%modify_particle (pdg_in, stable = .false., &
                decay = cmd%process_id, &
                isotropic_decay = isotropic_decay, &
                diagonal_decay = diagonal_decay, &
                polarized = .false.)
        end if
        u_tmp = free_unit ()
        open (u_tmp, status = "scratch", action = "readwrite")
        call show_unstable (global, pdg_in, u_tmp)
        rewind (u_tmp)
        do
           read (u_tmp, "(A)", end = 1)  buffer
           write (msg_buffer, "(A)")  trim (buffer)
           call msg_message ()
        end do
 1      continue
        close (u_tmp)
     else
        call err_unstable (global, pdg_in)
     end if
   end subroutine cmd_unstable_execute
 
 @ %def cmd_unstable_execute
 @ Show data for the current unstable particle.  This is called both by
 the [[unstable]] and by the [[show]] command.
 
 To determine decay branching rations, we look at the decay process IDs
 and inspect the corresponding [[integral()]] result variables.
 <<Commands: procedures>>=
   subroutine show_unstable (global, pdg, u)
     type(rt_data_t), intent(in), target :: global
     integer, intent(in) :: pdg, u
     type(flavor_t) :: flv
     type(string_t), dimension(:), allocatable :: decay
     real(default), dimension(:), allocatable :: br
     real(default) :: width
     type(process_t), pointer :: process
     type(process_component_def_t), pointer :: prc_def
     type(string_t), dimension(:), allocatable :: prt_out, prt_out_str
     integer :: i, j
     logical :: opened
     call flv%init (pdg, global%model)
     call flv%get_decays (decay)
     if (.not. allocated (decay))  return
     allocate (prt_out_str (size (decay)))
     allocate (br (size (decay)))
     do i = 1, size (br)
        process => global%process_stack%get_process_ptr (decay(i))
        prc_def => process%get_component_def_ptr (1)
        call prc_def%get_prt_out (prt_out)
        prt_out_str(i) = prt_out(1)
        do j = 2, size (prt_out)
           prt_out_str(i) = prt_out_str(i) // ", " // prt_out(j)
        end do
        br(i) = global%get_rval ("integral(" // decay(i) // ")")
     end do
     if (all (br >= 0)) then
        if (any (br > 0)) then
           width = sum (br)
           br = br / sum (br)
           write (u, "(A)") "Unstable particle " &
                // char (flv%get_name ()) &
                // ": computed branching ratios:"
           do i = 1, size (br)
              write (u, "(2x,A,':'," // FMT_14 // ",3x,A)") &
                   char (decay(i)), br(i), char (prt_out_str(i))
           end do
           write (u, "(2x,'Total width ='," // FMT_14 // ",' GeV (computed)')")  width
           write (u, "(2x,'            ='," // FMT_14 // ",' GeV (preset)')") &
                flv%get_width ()
           if (flv%decays_isotropically ()) then
              write (u, "(2x,A)")  "Decay options: isotropic"
           else if (flv%decays_diagonal ()) then
              write (u, "(2x,A)")  "Decay options: &
                   &projection on diagonal helicity states"
           else if (flv%has_decay_helicity ()) then
              write (u, "(2x,A,1x,I0)")  "Decay options: projection onto helicity =", &
                   flv%get_decay_helicity ()
           else
              write (u, "(2x,A)")  "Decay options: helicity treated exactly"
           end if
        else
           inquire (unit = u, opened = opened)
           if (opened .and. .not. mask_fatal_errors)  close (u)
           call msg_fatal ("Unstable particle " &
                // char (flv%get_name ()) &
                // ": partial width vanishes for all decay channels")
        end if
     else
        inquire (unit = u, opened = opened)
        if (opened .and. .not. mask_fatal_errors)  close (u)
        call msg_fatal ("Unstable particle " &
                // char (flv%get_name ()) &
                // ": partial width is negative")
     end if
   end subroutine show_unstable
 
 @ %def show_unstable
 @ If no decays have been found, issue a non-fatal error.
 <<Commands: procedures>>=
   subroutine err_unstable (global, pdg)
     type(rt_data_t), intent(in), target :: global
     integer, intent(in) :: pdg
     type(flavor_t) :: flv
     call flv%init (pdg, global%model)
     call msg_error ("Unstable: no allowed decays found for particle " &
          // char (flv%get_name ()) // ", keeping as stable")
   end subroutine err_unstable
 
 @ %def err_unstable
 @ Auto decays: create process IDs and make up process
 configurations, using the PDG codes generated by the [[ds_table]] make
 method.
 
 We allocate and use a self-contained process library that contains only the
 decay processes of the current particle.  When done, we revert the global
 library pointer to the original library but return the name of the new one.
 The new library becomes part of the global library stack and can thus be
 referred to at any time.
 <<Commands: procedures>>=
   subroutine create_auto_decays &
        (pdg_in, mult, rad, libname_dec, process_id, global)
     integer, intent(in) :: pdg_in
     integer, intent(in) :: mult
     logical, intent(in) :: rad
     type(string_t), intent(out) :: libname_dec
     type(string_t), dimension(:), allocatable, intent(out) :: process_id
     type(rt_data_t), intent(inout) :: global
     type(prclib_entry_t), pointer :: lib_entry
     type(process_library_t), pointer :: lib
     type(ds_table_t) :: ds_table
     type(split_constraints_t) :: constraints
     type(pdg_array_t), dimension(:), allocatable :: pa_out
     character(80) :: buffer
     character :: p_or_a
     type(string_t) :: process_string, libname_cur
     type(flavor_t) :: flv_in, flv_out
     type(string_t) :: prt_in
     type(string_t), dimension(:), allocatable :: prt_out
     type(process_configuration_t) :: prc_config
     integer :: i, j, k
     call flv_in%init (pdg_in, global%model)
     if (rad) then
        call constraints%init (2)
     else
        call constraints%init (3)
        call constraints%set (3, constrain_radiation ())
     end if
     call constraints%set (1, constrain_n_tot (mult))
     call constraints%set (2, &
          constrain_mass_sum (flv_in%get_mass (), margin = 0._default))
     call ds_table%make (global%model, pdg_in, constraints)
     prt_in = flv_in%get_name ()
     if (pdg_in > 0) then
        p_or_a = "p"
     else
        p_or_a = "a"
     end if
     if (ds_table%get_length () == 0) then
        call msg_warning ("Auto-decays: Particle " // char (prt_in) // ": " &
             // "no decays found")
        libname_dec = ""
        allocate (process_id (0))
     else
        call msg_message ("Creating decay process library for particle " &
             // char (prt_in))
        libname_cur = global%prclib%get_name ()
        write (buffer, "(A,A,I0)")  "_d", p_or_a, abs (pdg_in)
        libname_dec = libname_cur // trim (buffer)
        lib => global%prclib_stack%get_library_ptr (libname_dec)
        if (.not. (associated (lib))) then
           allocate (lib_entry)
           call lib_entry%init (libname_dec)
           lib => lib_entry%process_library_t
           call global%add_prclib (lib_entry)
        else
           call global%update_prclib (lib)
        end if
        allocate (process_id (ds_table%get_length ()))
        do i = 1, size (process_id)
           write (buffer, "(A,'_',A,I0,'_',I0)") &
                "decay", p_or_a, abs (pdg_in), i
           process_id(i) = trim (buffer)
           process_string = process_id(i) // ": " // prt_in // " =>"
           call ds_table%get_pdg_out (i, pa_out)
           allocate (prt_out (size (pa_out)))
           do j = 1, size (pa_out)
              do k = 1, pa_out(j)%get_length ()
                 call flv_out%init (pa_out(j)%get (k), global%model)
                 if (k == 1) then
                    prt_out(j) = flv_out%get_name ()
                 else
                    prt_out(j) = prt_out(j) // ":" // flv_out%get_name ()
                 end if
              end do
              process_string = process_string // " " // prt_out(j)
           end do
           call msg_message (char (process_string))
           call prc_config%init (process_id(i), 1, 1, &
                global%model, global%var_list, &
                nlo_process = global%nlo_fixed_order)
           call prc_config%setup_component (1, new_prt_spec ([prt_in]), &
                new_prt_spec (prt_out), global%model, global%var_list)
           call prc_config%record (global)
           deallocate (prt_out)
           deallocate (pa_out)
        end do
        lib => global%prclib_stack%get_library_ptr (libname_cur)
        call global%update_prclib (lib)
     end if
     call ds_table%final ()
   end subroutine create_auto_decays
 
 @ %def create_auto_decays
 @
 \subsubsection{(Stable particles}
 Revert the unstable declaration for a list of particles.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_stable_t
      private
      type(parse_node_p), dimension(:), allocatable :: pn_pdg
    contains
    <<Commands: cmd stable: TBP>>
   end type cmd_stable_t
 
 @ %def cmd_stable_t
 @ Output: we know only the number of particles.
 <<Commands: cmd stable: TBP>>=
   procedure :: write => cmd_stable_write
 <<Commands: procedures>>=
   subroutine cmd_stable_write (cmd, unit, indent)
     class(cmd_stable_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,1x,I0)")  "stable:", size (cmd%pn_pdg)
   end subroutine cmd_stable_write
 
 @ %def cmd_stable_write
 @ Compile.  Assign parse nodes for the particle IDs.
 <<Commands: cmd stable: TBP>>=
   procedure :: compile => cmd_stable_compile
 <<Commands: procedures>>=
   subroutine cmd_stable_compile (cmd, global)
     class(cmd_stable_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_list, pn_prt
     integer :: n, i
     pn_list => parse_node_get_sub_ptr (cmd%pn, 2)
     cmd%pn_opt => parse_node_get_next_ptr (pn_list)
     call cmd%compile_options (global)
     n = parse_node_get_n_sub (pn_list)
     allocate (cmd%pn_pdg (n))
     pn_prt => parse_node_get_sub_ptr (pn_list)
     i = 1
     do while (associated (pn_prt))
        cmd%pn_pdg(i)%ptr => pn_prt
        pn_prt  => parse_node_get_next_ptr (pn_prt)
        i = i + 1
     end do
   end subroutine cmd_stable_compile
 
 @ %def cmd_stable_compile
 @ Execute: apply the modifications to the current model.
 <<Commands: cmd stable: TBP>>=
   procedure :: execute => cmd_stable_execute
 <<Commands: procedures>>=
   subroutine cmd_stable_execute (cmd, global)
     class(cmd_stable_t), intent(inout) :: cmd
     type(rt_data_t), target, intent(inout) :: global
     type(var_list_t), pointer :: var_list
     type(pdg_array_t) :: pa
     integer :: pdg
     type(flavor_t) :: flv
     integer :: i
     var_list => cmd%local%get_var_list_ptr ()
     do i = 1, size (cmd%pn_pdg)
        pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
        if (pdg_array_get_length (pa) /= 1) &
             call msg_fatal ("Stable: listed particles must be unique")
        pdg = pdg_array_get (pa, 1)
        call global%modify_particle (pdg, stable = .true., &
          isotropic_decay = .false., &
          diagonal_decay = .false., &
          polarized = .false.)
        call flv%init (pdg, cmd%local%model)
        call msg_message ("Particle " &
             // char (flv%get_name ()) &
             // " declared as stable")
     end do
   end subroutine cmd_stable_execute
 
 @ %def cmd_stable_execute
 @
 \subsubsection{Polarized particles}
 These commands mark particles as (un)polarized, to be applied in
 subsequent simulation passes.  Since this is technically the same as
 the [[stable]] command, we take a shortcut and make this an extension,
 just overriding methods.
 <<Commands: types>>=
   type, extends (cmd_stable_t) :: cmd_polarized_t
    contains
    <<Commands: cmd polarized: TBP>>
   end type cmd_polarized_t
 
   type, extends (cmd_stable_t) :: cmd_unpolarized_t
    contains
    <<Commands: cmd unpolarized: TBP>>
   end type cmd_unpolarized_t
 
 @ %def cmd_polarized_t cmd_unpolarized_t
 @ Output: we know only the number of particles.
 <<Commands: cmd polarized: TBP>>=
   procedure :: write => cmd_polarized_write
 <<Commands: cmd unpolarized: TBP>>=
   procedure :: write => cmd_unpolarized_write
 <<Commands: procedures>>=
   subroutine cmd_polarized_write (cmd, unit, indent)
     class(cmd_polarized_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,1x,I0)")  "polarized:", size (cmd%pn_pdg)
   end subroutine cmd_polarized_write
 
   subroutine cmd_unpolarized_write (cmd, unit, indent)
     class(cmd_unpolarized_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,1x,I0)")  "unpolarized:", size (cmd%pn_pdg)
   end subroutine cmd_unpolarized_write
 
 @ %def cmd_polarized_write
 @ %def cmd_unpolarized_write
 @ Compile: accounted for by the base command.
 
 Execute: apply the modifications to the current model.
 <<Commands: cmd polarized: TBP>>=
   procedure :: execute => cmd_polarized_execute
 <<Commands: cmd unpolarized: TBP>>=
   procedure :: execute => cmd_unpolarized_execute
 <<Commands: procedures>>=
   subroutine cmd_polarized_execute (cmd, global)
     class(cmd_polarized_t), intent(inout) :: cmd
     type(rt_data_t), target, intent(inout) :: global
     type(var_list_t), pointer :: var_list
     type(pdg_array_t) :: pa
     integer :: pdg
     type(flavor_t) :: flv
     integer :: i
     var_list => cmd%local%get_var_list_ptr ()
     do i = 1, size (cmd%pn_pdg)
        pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
        if (pdg_array_get_length (pa) /= 1) &
             call msg_fatal ("Polarized: listed particles must be unique")
        pdg = pdg_array_get (pa, 1)
        call global%modify_particle (pdg, polarized = .true., &
             stable = .true., &
             isotropic_decay = .false., &
             diagonal_decay = .false.)
        call flv%init (pdg, cmd%local%model)
        call msg_message ("Particle " &
             // char (flv%get_name ()) &
             // " declared as polarized")
     end do
   end subroutine cmd_polarized_execute
 
   subroutine cmd_unpolarized_execute (cmd, global)
     class(cmd_unpolarized_t), intent(inout) :: cmd
     type(rt_data_t), target, intent(inout) :: global
     type(var_list_t), pointer :: var_list
     type(pdg_array_t) :: pa
     integer :: pdg
     type(flavor_t) :: flv
     integer :: i
     var_list => cmd%local%get_var_list_ptr ()
     do i = 1, size (cmd%pn_pdg)
        pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
        if (pdg_array_get_length (pa) /= 1) &
             call msg_fatal ("Unpolarized: listed particles must be unique")
        pdg = pdg_array_get (pa, 1)
        call global%modify_particle (pdg, polarized = .false., &
             stable = .true., &
             isotropic_decay = .false., &
             diagonal_decay = .false.)
        call flv%init (pdg, cmd%local%model)
        call msg_message ("Particle " &
             // char (flv%get_name ()) &
             // " declared as unpolarized")
     end do
   end subroutine cmd_unpolarized_execute
 
 @ %def cmd_polarized_execute
 @ %def cmd_unpolarized_execute
 @
 \subsubsection{Parameters: formats for event-sample output}
 Specify all event formats that are to be used for output files in the
 subsequent simulation run.  (The raw format is on by default and can be turned
 off here.)
 <<Commands: types>>=
   type, extends (command_t) :: cmd_sample_format_t
      private
      type(string_t), dimension(:), allocatable :: format
    contains
    <<Commands: cmd sample format: TBP>>
   end type cmd_sample_format_t
 
 @ %def cmd_sample_format_t
 @ Output: here, everything is known.
 <<Commands: cmd sample format: TBP>>=
   procedure :: write => cmd_sample_format_write
 <<Commands: procedures>>=
   subroutine cmd_sample_format_write (cmd, unit, indent)
     class(cmd_sample_format_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "sample_format = "
     do i = 1, size (cmd%format)
        if (i > 1)  write (u, "(A,1x)", advance="no")  ","
        write (u, "(A)", advance="no")  char (cmd%format(i))
     end do
     write (u, "(A)")
   end subroutine cmd_sample_format_write
 
 @ %def cmd_sample_format_write
 @ Compile.  Initialize evaluation trees.
 <<Commands: cmd sample format: TBP>>=
   procedure :: compile => cmd_sample_format_compile
 <<Commands: procedures>>=
   subroutine cmd_sample_format_compile (cmd, global)
     class(cmd_sample_format_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg
     type(parse_node_t), pointer :: pn_format
     integer :: i, n_format
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
     if (associated (pn_arg)) then
        n_format = parse_node_get_n_sub (pn_arg)
        allocate (cmd%format (n_format))
        pn_format => parse_node_get_sub_ptr (pn_arg)
        i = 0
        do while (associated (pn_format))
           i = i + 1
           cmd%format(i) = parse_node_get_string (pn_format)
           pn_format => parse_node_get_next_ptr (pn_format)
        end do
     else
        allocate (cmd%format (0))
     end if
   end subroutine cmd_sample_format_compile
 
 @ %def cmd_sample_format_compile
 @ Execute.  Transfer the list of format specifications to the
 corresponding array in the runtime data set.
 <<Commands: cmd sample format: TBP>>=
   procedure :: execute => cmd_sample_format_execute
 <<Commands: procedures>>=
   subroutine cmd_sample_format_execute (cmd, global)
     class(cmd_sample_format_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     if (allocated (global%sample_fmt))  deallocate (global%sample_fmt)
     allocate (global%sample_fmt (size (cmd%format)), source = cmd%format)
   end subroutine cmd_sample_format_execute
 
 @ %def cmd_sample_format_execute
 @
 \subsubsection{The simulate command}
 This is the actual SINDARIN command.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_simulate_t
      ! not private anymore as required by the whizard-c-interface
      integer :: n_proc = 0
      type(string_t), dimension(:), allocatable :: process_id
    contains
    <<Commands: cmd simulate: TBP>>
   end type cmd_simulate_t
 
 @ %def cmd_simulate_t
 @ Output: we know the process IDs.
 <<Commands: cmd simulate: TBP>>=
   procedure :: write => cmd_simulate_write
 <<Commands: procedures>>=
   subroutine cmd_simulate_write (cmd, unit, indent)
     class(cmd_simulate_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "simulate ("
     do i = 1, cmd%n_proc
        if (i > 1)  write (u, "(A,1x)", advance="no")  ","
        write (u, "(A)", advance="no")  char (cmd%process_id(i))
     end do
     write (u, "(A)")  ")"
   end subroutine cmd_simulate_write
 
 @ %def cmd_simulate_write
 @ Compile. In contrast to WHIZARD 1 the confusing option to give the
 number of unweighted events for weighted events as if unweighting were
 to take place has been abandoned. (We both use [[n_events]] for
 weighted and unweighted events, the variable [[n_calls]] from WHIZARD
 1 has been discarded.
 <<Commands: cmd simulate: TBP>>=
   procedure :: compile => cmd_simulate_compile
 <<Commands: procedures>>=
   subroutine cmd_simulate_compile (cmd, global)
     class(cmd_simulate_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_proclist, pn_proc
     integer :: i
     pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2)
     cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
     call cmd%compile_options (global)
     cmd%n_proc = parse_node_get_n_sub (pn_proclist)
     allocate (cmd%process_id (cmd%n_proc))
     pn_proc => parse_node_get_sub_ptr (pn_proclist)
     do i = 1, cmd%n_proc
        cmd%process_id(i) = parse_node_get_string (pn_proc)
        call global%process_stack%init_result_vars (cmd%process_id(i))
        pn_proc => parse_node_get_next_ptr (pn_proc)
     end do
   end subroutine cmd_simulate_compile
 
 @ %def cmd_simulate_compile
 @ Execute command:  Simulate events.  This is done via a [[simulation_t]]
 object and its associated methods.
 
 Signal handling: the [[generate]] method may exit abnormally if there is a
 pending signal.  The current logic ensures that the [[es_array]] output
 channels are closed before the [[execute]] routine returns.  The program will
 terminate then in [[command_list_execute]].
 <<Commands: cmd simulate: TBP>>=
   procedure :: execute => cmd_simulate_execute
 <<Commands: procedures>>=
   subroutine cmd_simulate_execute (cmd, global)
     class(cmd_simulate_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(rt_data_t), dimension(:), allocatable, target :: alt_env
     integer :: n_events
     type(simulation_t), target :: sim
     type(event_stream_array_t) :: es_array
     integer :: i, checkpoint, callback
     var_list => cmd%local%var_list
     if (cmd%local%nlo_fixed_order) then
        call check_nlo_options (cmd%local)
     end if
     if (allocated (cmd%local%pn%alt_setup)) then
        allocate (alt_env (size (cmd%local%pn%alt_setup)))
        do i = 1, size (alt_env)
           call build_alt_setup (alt_env(i), cmd%local, &
                cmd%local%pn%alt_setup(i)%ptr)
        end do
        call sim%init (cmd%process_id, .true., .true., cmd%local, global, &
             alt_env)
     else
        call sim%init (cmd%process_id, .true., .true., cmd%local, global)
     end if
     if (signal_is_pending ())  return
     if (sim%is_valid ()) then
        call sim%init_process_selector ()
        call sim%setup_openmp ()
        call sim%compute_n_events (n_events)
        call sim%set_n_events_requested (n_events)
        call sim%activate_extra_logging ()
        call sim%prepare_event_streams (es_array)
        if (es_array%is_valid ()) then
           call sim%generate (es_array)
        else
           call sim%generate ()
        end if
        call es_array%final ()
        if (allocated (alt_env)) then
           do i = 1, size (alt_env)
              call alt_env(i)%local_final ()
           end do
        end if
     end if
     call sim%final ()
   end subroutine cmd_simulate_execute
 
 @ %def cmd_simulate_execute
 @ Build an alternative setup: the parse tree is stored in the global
 environment.  We create a temporary command list to compile and execute this;
 the result is an alternative local environment [[alt_env]] which we can hand
 over to the [[simulate]] command.
 <<Commands: procedures>>=
   recursive subroutine build_alt_setup (alt_env, global, pn)
     type(rt_data_t), intent(inout), target :: alt_env
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), intent(in), target :: pn
     type(command_list_t), allocatable :: alt_options
     allocate (alt_options)
     call alt_env%local_init (global)
     call alt_env%activate ()
     call alt_options%compile (pn, alt_env)
     call alt_options%execute (alt_env)
     call alt_env%deactivate (global, keep_local = .true.)
     call alt_options%final ()
   end subroutine build_alt_setup
 
 @ %def build_alt_setup
 @
 \subsubsection{The rescan command}
 This is the actual SINDARIN command.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_rescan_t
      ! private
      type(parse_node_t), pointer :: pn_filename => null ()
      integer :: n_proc = 0
      type(string_t), dimension(:), allocatable :: process_id
    contains
    <<Commands: cmd rescan: TBP>>
   end type cmd_rescan_t
 
 @ %def cmd_rescan_t
 @ Output: we know the process IDs.
 <<Commands: cmd rescan: TBP>>=
   procedure :: write => cmd_rescan_write
 <<Commands: procedures>>=
   subroutine cmd_rescan_write (cmd, unit, indent)
     class(cmd_rescan_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "rescan ("
     do i = 1, cmd%n_proc
        if (i > 1)  write (u, "(A,1x)", advance="no")  ","
        write (u, "(A)", advance="no")  char (cmd%process_id(i))
     end do
     write (u, "(A)")  ")"
   end subroutine cmd_rescan_write
 
 @ %def cmd_rescan_write
 @ Compile.  The command takes a suffix argument, namely the file name
 of requested event file.
 <<Commands: cmd rescan: TBP>>=
   procedure :: compile => cmd_rescan_compile
 <<Commands: procedures>>=
   subroutine cmd_rescan_compile (cmd, global)
     class(cmd_rescan_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_filename, pn_proclist, pn_proc
     integer :: i
     pn_filename => parse_node_get_sub_ptr (cmd%pn, 2)
     pn_proclist => parse_node_get_next_ptr (pn_filename)
     cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
     call cmd%compile_options (global)
     cmd%pn_filename => pn_filename
     cmd%n_proc = parse_node_get_n_sub (pn_proclist)
     allocate (cmd%process_id (cmd%n_proc))
     pn_proc => parse_node_get_sub_ptr (pn_proclist)
     do i = 1, cmd%n_proc
        cmd%process_id(i) = parse_node_get_string (pn_proc)
        pn_proc => parse_node_get_next_ptr (pn_proc)
     end do
   end subroutine cmd_rescan_compile
 
 @ %def cmd_rescan_compile
 @ Execute command:  Rescan events.  This is done via a [[simulation_t]]
 object and its associated methods.
 <<Commands: cmd rescan: TBP>>=
   procedure :: execute => cmd_rescan_execute
 <<Commands: procedures>>=
   subroutine cmd_rescan_execute (cmd, global)
     class(cmd_rescan_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(rt_data_t), dimension(:), allocatable, target :: alt_env
     type(string_t) :: sample, sample_suffix
     logical :: exist, write_raw, update_event, update_sqme
     type(simulation_t), target :: sim
     type(event_sample_data_t) :: input_data, data
     type(string_t) :: input_sample
     integer :: n_fmt
     type(string_t), dimension(:), allocatable :: sample_fmt
     type(string_t) :: input_format, input_ext, input_file
     type(string_t) :: lhef_extension, extension_hepmc, extension_lcio
     type(event_stream_array_t) :: es_array
     integer :: i, n_events
   <<Commands: cmd rescan execute: extra variables>>
     var_list => cmd%local%var_list
     if (allocated (cmd%local%pn%alt_setup)) then
        allocate (alt_env (size (cmd%local%pn%alt_setup)))
        do i = 1, size (alt_env)
           call build_alt_setup (alt_env(i), cmd%local, &
                cmd%local%pn%alt_setup(i)%ptr)
        end do
        call sim%init (cmd%process_id, .false., .false., cmd%local, global, &
             alt_env)
     else
        call sim%init (cmd%process_id, .false., .false., cmd%local, global)
     end if
     call sim%compute_n_events (n_events)
     input_sample = eval_string (cmd%pn_filename, var_list)
     input_format = var_list%get_sval (&
          var_str ("$rescan_input_format"))
     sample_suffix = ""
   <<Commands: cmd rescan execute: extra init>>
     sample = var_list%get_sval (var_str ("$sample"))
     if (sample == "") then
        sample = sim%get_default_sample_name () // sample_suffix
     else
        sample = var_list%get_sval (var_str ("$sample")) // sample_suffix
     end if
     write_raw = var_list%get_lval (var_str ("?write_raw"))
     if (allocated (cmd%local%sample_fmt)) then
        n_fmt = size (cmd%local%sample_fmt)
     else
        n_fmt = 0
     end if
     if (write_raw) then
        if (sample == input_sample) then
           call msg_error ("Rescan: ?write_raw = true: " &
                // "suppressing raw event output (filename clashes with input)")
           allocate (sample_fmt (n_fmt))
           if (n_fmt > 0)  sample_fmt = cmd%local%sample_fmt
        else
           allocate (sample_fmt (n_fmt + 1))
           if (n_fmt > 0)  sample_fmt(:n_fmt) = cmd%local%sample_fmt
           sample_fmt(n_fmt+1) = var_str ("raw")
        end if
     else
        allocate (sample_fmt (n_fmt))
        if (n_fmt > 0)  sample_fmt = cmd%local%sample_fmt
     end if
     update_event = &
          var_list%get_lval (var_str ("?update_event"))
     update_sqme = &
          var_list%get_lval (var_str ("?update_sqme"))
     if (update_event .or. update_sqme) then
        call msg_message ("Recalculating observables")
        if (update_sqme) then
           call msg_message ("Recalculating squared matrix elements")
        end if
     end if
     lhef_extension = &
          var_list%get_sval (var_str ("$lhef_extension"))
     extension_hepmc = &
          var_list%get_sval (var_str ("$extension_hepmc"))
     extension_lcio = &
          var_list%get_sval (var_str ("$extension_lcio"))
     select case (char (input_format))
     case ("raw");  input_ext = "evx"
        call cmd%local%set_log &
             (var_str ("?recover_beams"), .false., is_known=.true.)
     case ("lhef"); input_ext = lhef_extension
     case ("hepmc"); input_ext = extension_hepmc
     case ("lcio"); input_ext = extension_lcio
     case default
        call msg_fatal ("rescan: input sample format '" // char (input_format) &
             // "' not supported")
     end select
     input_file = input_sample // "." // input_ext
     inquire (file = char (input_file), exist = exist)
     if (exist) then
        input_data = sim%get_data (alt = .false.)
        input_data%n_evt = n_events
        data = sim%get_data ()
        data%n_evt = n_events
        input_data%md5sum_cfg = ""
        call es_array%init (sample, &
             sample_fmt, cmd%local, data, &
             input = input_format, input_sample = input_sample, &
             input_data = input_data, &
             allow_switch = .false.)
        call sim%rescan (n_events, es_array, global = cmd%local)
        call es_array%final ()
     else
        call msg_fatal ("Rescan: event file '" &
             // char (input_file) // "' not found")
     end if
     if (allocated (alt_env)) then
        do i = 1, size (alt_env)
           call alt_env(i)%local_final ()
        end do
     end if
     call sim%final ()
   end subroutine cmd_rescan_execute
 
 @ %def cmd_rescan_execute
 @ MPI: Append rank id to sample name.
 <<Commands: cmd rescan execute: extra variables>>=
 <<MPI: Commands: cmd rescan execute: extra variables>>=
   logical :: mpi_logging
   integer :: rank, n_size
 <<Commands: cmd rescan execute: extra init>>=
 <<MPI: Commands: cmd rescan execute: extra init>>=
   call mpi_get_comm_id (n_size, rank)
   if (n_size > 1) then
      sample_suffix = var_str ("_") // str (rank)
   end if
   mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) &
        & .and. (n_size > 1)) &
        & .or. var_list%get_lval (var_str ("?mpi_logging")))
   call mpi_set_logging (mpi_logging)
 @
 \subsubsection{Parameters: number of iterations}
 Specify number of iterations and number of calls for one integration pass.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_iterations_t
      private
      integer :: n_pass = 0
      type(parse_node_p), dimension(:), allocatable :: pn_expr_n_it
      type(parse_node_p), dimension(:), allocatable :: pn_expr_n_calls
      type(parse_node_p), dimension(:), allocatable :: pn_sexpr_adapt
    contains
    <<Commands: cmd iterations: TBP>>
   end type cmd_iterations_t
 
 @ %def cmd_iterations_t
 @ Output.  Display the number of passes, which is known after compilation.
 <<Commands: cmd iterations: TBP>>=
   procedure :: write => cmd_iterations_write
 <<Commands: procedures>>=
   subroutine cmd_iterations_write (cmd, unit, indent)
     class(cmd_iterations_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     select case (cmd%n_pass)
     case (0)
        write (u, "(1x,A)")  "iterations: [empty]"
     case (1)
        write (u, "(1x,A,I0,A)")  "iterations: ", cmd%n_pass, " pass"
     case default
        write (u, "(1x,A,I0,A)")  "iterations: ", cmd%n_pass, " passes"
     end select
   end subroutine cmd_iterations_write
 
 @ %def cmd_iterations_write
 @ Compile.  Initialize evaluation trees.
 <<Commands: cmd iterations: TBP>>=
   procedure :: compile => cmd_iterations_compile
 <<Commands: procedures>>=
   subroutine cmd_iterations_compile (cmd, global)
     class(cmd_iterations_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg, pn_n_it, pn_n_calls, pn_adapt
     type(parse_node_t), pointer :: pn_it_spec, pn_calls_spec, pn_adapt_spec
     integer :: i
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
     if (associated (pn_arg)) then
        cmd%n_pass = parse_node_get_n_sub (pn_arg)
        allocate (cmd%pn_expr_n_it (cmd%n_pass))
        allocate (cmd%pn_expr_n_calls (cmd%n_pass))
        allocate (cmd%pn_sexpr_adapt (cmd%n_pass))
        pn_it_spec => parse_node_get_sub_ptr (pn_arg)
        i = 1
        do while (associated (pn_it_spec))
           pn_n_it => parse_node_get_sub_ptr (pn_it_spec)
           pn_calls_spec => parse_node_get_next_ptr (pn_n_it)
           pn_n_calls => parse_node_get_sub_ptr (pn_calls_spec, 2)
           pn_adapt_spec => parse_node_get_next_ptr (pn_calls_spec)
           if (associated (pn_adapt_spec)) then
              pn_adapt => parse_node_get_sub_ptr (pn_adapt_spec, 2)
           else
              pn_adapt => null ()
           end if
           cmd%pn_expr_n_it(i)%ptr => pn_n_it
           cmd%pn_expr_n_calls(i)%ptr => pn_n_calls
           cmd%pn_sexpr_adapt(i)%ptr => pn_adapt
           i = i + 1
           pn_it_spec => parse_node_get_next_ptr (pn_it_spec)
        end do
     else
        allocate (cmd%pn_expr_n_it (0))
        allocate (cmd%pn_expr_n_calls (0))
     end if
   end subroutine cmd_iterations_compile
 
 @ %def cmd_iterations_compile
 @ Execute.  Evaluate the trees and transfer the results to the iteration
 list in the runtime data set.
 <<Commands: cmd iterations: TBP>>=
   procedure :: execute => cmd_iterations_execute
 <<Commands: procedures>>=
   subroutine cmd_iterations_execute (cmd, global)
     class(cmd_iterations_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     integer, dimension(cmd%n_pass) :: n_it, n_calls
     logical, dimension(cmd%n_pass) :: custom_adapt
     type(string_t), dimension(cmd%n_pass) :: adapt_code
     integer :: i
     var_list => global%get_var_list_ptr ()
     do i = 1, cmd%n_pass
        n_it(i) = eval_int (cmd%pn_expr_n_it(i)%ptr, var_list)
        n_calls(i) = &
             eval_int (cmd%pn_expr_n_calls(i)%ptr, var_list)
        if (associated (cmd%pn_sexpr_adapt(i)%ptr)) then
           adapt_code(i) = &
                eval_string (cmd%pn_sexpr_adapt(i)%ptr, &
                             var_list, is_known = custom_adapt(i))
        else
           custom_adapt(i) = .false.
        end if
     end do
     call global%it_list%init (n_it, n_calls, custom_adapt, adapt_code)
   end subroutine cmd_iterations_execute
 
 @ %def cmd_iterations_execute
 @
 \subsubsection{Range expressions}
 We need a special type for storing and evaluating range expressions.
 <<Commands: parameters>>=
   integer, parameter :: STEP_NONE = 0
   integer, parameter :: STEP_ADD = 1
   integer, parameter :: STEP_SUB = 2
   integer, parameter :: STEP_MUL = 3
   integer, parameter :: STEP_DIV = 4
   integer, parameter :: STEP_COMP_ADD = 11
   integer, parameter :: STEP_COMP_MUL = 13
 @
 There is an abstract base type and two implementations: scan over integers and
 scan over reals.
 <<Commands: types>>=
   type, abstract :: range_t
      type(parse_node_t), pointer :: pn_expr => null ()
      type(parse_node_t), pointer :: pn_term => null ()
      type(parse_node_t), pointer :: pn_factor => null ()
      type(parse_node_t), pointer :: pn_value => null ()
      type(parse_node_t), pointer :: pn_literal => null ()
      type(parse_node_t), pointer :: pn_beg => null ()
      type(parse_node_t), pointer :: pn_end => null ()
      type(parse_node_t), pointer :: pn_step => null ()
      type(eval_tree_t) :: expr_beg
      type(eval_tree_t) :: expr_end
      type(eval_tree_t) :: expr_step
      integer :: step_mode = 0
      integer :: n_step = 0
    contains
    <<Commands: range: TBP>>
   end type range_t
 
 @ %def range_t
 @ These are the implementations:
 <<Commands: types>>=
   type, extends (range_t) :: range_int_t
      integer :: i_beg = 0
      integer :: i_end = 0
      integer :: i_step = 0
    contains
    <<Commands: range int: TBP>>
 end type range_int_t
 
   type, extends (range_t) :: range_real_t
      real(default) :: r_beg = 0
      real(default) :: r_end = 0
      real(default) :: r_step = 0
      real(default) :: lr_beg  = 0
      real(default) :: lr_end  = 0
      real(default) :: lr_step = 0
    contains
    <<Commands: range real: TBP>>
 end type range_real_t
 
 @ %def range_int_t range_real_t
 @ Finalize the allocated dummy node.  The other nodes are just pointers.
 <<Commands: range: TBP>>=
   procedure :: final => range_final
 <<Commands: procedures>>=
   subroutine range_final (object)
     class(range_t), intent(inout) :: object
     if (associated (object%pn_expr)) then
        call parse_node_final (object%pn_expr, recursive = .false.)
        call parse_node_final (object%pn_term, recursive = .false.)
        call parse_node_final (object%pn_factor, recursive = .false.)
        call parse_node_final (object%pn_value, recursive = .false.)
        call parse_node_final (object%pn_literal, recursive = .false.)
        deallocate (object%pn_expr)
        deallocate (object%pn_term)
        deallocate (object%pn_factor)
        deallocate (object%pn_value)
        deallocate (object%pn_literal)
     end if
   end subroutine range_final
 
 @ %def range_final
 @ Output.
 <<Commands: range: TBP>>=
   procedure (range_write), deferred :: write
   procedure :: base_write => range_write
 <<Commands: range int: TBP>>=
   procedure :: write => range_int_write
 <<Commands: range real: TBP>>=
   procedure :: write => range_real_write
 <<Commands: procedures>>=
   subroutine range_write (object, unit)
     class(range_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Range specification:"
     if (associated (object%pn_expr)) then
        write (u, "(1x,A)")  "Dummy value:"
        call parse_node_write_rec (object%pn_expr, u)
     end if
     if (associated (object%pn_beg)) then
        write (u, "(1x,A)")  "Initial value:"
        call parse_node_write_rec (object%pn_beg, u)
        call object%expr_beg%write (u)
        if (associated (object%pn_end)) then
           write (u, "(1x,A)")  "Final value:"
           call parse_node_write_rec (object%pn_end, u)
           call object%expr_end%write (u)
           if (associated (object%pn_step)) then
              write (u, "(1x,A)")  "Step value:"
              call parse_node_write_rec (object%pn_step, u)
              select case (object%step_mode)
              case (STEP_ADD);   write (u, "(1x,A)")  "Step mode: +"
              case (STEP_SUB);   write (u, "(1x,A)")  "Step mode: -"
              case (STEP_MUL);   write (u, "(1x,A)")  "Step mode: *"
              case (STEP_DIV);   write (u, "(1x,A)")  "Step mode: /"
              case (STEP_COMP_ADD);  write (u, "(1x,A)")  "Division mode: +"
              case (STEP_COMP_MUL);  write (u, "(1x,A)")  "Division mode: *"
              end select
           end if
        end if
     else
        write (u, "(1x,A)")  "Expressions: [undefined]"
     end if
   end subroutine range_write
 
   subroutine range_int_write (object, unit)
     class(range_int_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (unit)
     write (u, "(1x,A)")  "Range parameters:"
     write (u, "(3x,A,I0)")  "i_beg  = ", object%i_beg
     write (u, "(3x,A,I0)")  "i_end  = ", object%i_end
     write (u, "(3x,A,I0)")  "i_step = ", object%i_step
     write (u, "(3x,A,I0)")  "n_step = ", object%n_step
   end subroutine range_int_write
 
   subroutine range_real_write (object, unit)
     class(range_real_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (unit)
     write (u, "(1x,A)")  "Range parameters:"
     write (u, "(3x,A," // FMT_19 // ")")  "r_beg  = ", object%r_beg
     write (u, "(3x,A," // FMT_19 // ")")  "r_end  = ", object%r_end
     write (u, "(3x,A," // FMT_19 // ")")  "r_step = ", object%r_end
     write (u, "(3x,A,I0)")  "n_step = ", object%n_step
   end subroutine range_real_write
 
 @ %def range_write
 @ Initialize, given a range expression parse node.  This is common to the
 implementations.
 <<Commands: range: TBP>>=
   procedure :: init => range_init
 <<Commands: procedures>>=
   subroutine range_init (range, pn)
     class(range_t), intent(out) :: range
     type(parse_node_t), intent(in), target :: pn
     type(parse_node_t), pointer :: pn_spec, pn_end, pn_step_spec, pn_op
     select case (char (parse_node_get_rule_key (pn)))
     case ("expr")
     case ("range_expr")
        range%pn_beg => parse_node_get_sub_ptr (pn)
        pn_spec => parse_node_get_next_ptr (range%pn_beg)
        if (associated (pn_spec)) then
           pn_end => parse_node_get_sub_ptr (pn_spec, 2)
           range%pn_end => pn_end
           pn_step_spec => parse_node_get_next_ptr (pn_end)
           if (associated (pn_step_spec)) then
              pn_op => parse_node_get_sub_ptr (pn_step_spec)
              range%pn_step => parse_node_get_next_ptr (pn_op)
              select case (char (parse_node_get_rule_key (pn_op)))
              case ("/+");  range%step_mode = STEP_ADD
              case ("/-");  range%step_mode = STEP_SUB
              case ("/*");  range%step_mode = STEP_MUL
              case ("//");  range%step_mode = STEP_DIV
              case ("/+/");  range%step_mode = STEP_COMP_ADD
              case ("/*/");  range%step_mode = STEP_COMP_MUL
              case default
                 call range%write ()
                 call msg_bug ("Range: step mode not implemented")
              end select
           else
              range%step_mode = STEP_ADD
           end if
        else
           range%step_mode = STEP_NONE
        end if
        call range%create_value_node ()
     case default
        call msg_bug ("range expression: node type '" &
             // char (parse_node_get_rule_key (pn)) &
             // "' not implemented")
     end select
   end subroutine range_init
 
 @ %def range_init
 @ This method manually creates a parse node (actually, a cascade of parse
 nodes) that hold a constant value as a literal.  The idea is that this node is
 inserted as the right-hand side of a fake variable assignment, which is
 prepended to each scan iteration.  Before the variable
 assignment is compiled and executed, we can manually reset the value of the
 literal and thus pretend that the loop variable is assigned this value.
 <<Commands: range: TBP>>=
   procedure :: create_value_node => range_create_value_node
 <<Commands: procedures>>=
   subroutine range_create_value_node (range)
     class(range_t), intent(inout) :: range
     allocate (range%pn_literal)
     allocate (range%pn_value)
     select type (range)
     type is (range_int_t)
        call parse_node_create_value (range%pn_literal, &
             syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_literal")),&
             ival = 0)
        call parse_node_create_branch (range%pn_value, &
             syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_value")))
     type is (range_real_t)
        call parse_node_create_value (range%pn_literal, &
             syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_literal")),&
             rval = 0._default)
        call parse_node_create_branch (range%pn_value, &
             syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_value")))
     class default
        call msg_bug ("range: create value node: type not implemented")
     end select
     call parse_node_append_sub (range%pn_value, range%pn_literal)
     call parse_node_freeze_branch (range%pn_value)
     allocate (range%pn_factor)
     call parse_node_create_branch (range%pn_factor, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("factor")))
     call parse_node_append_sub (range%pn_factor, range%pn_value)
     call parse_node_freeze_branch (range%pn_factor)
     allocate (range%pn_term)
     call parse_node_create_branch (range%pn_term, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("term")))
     call parse_node_append_sub (range%pn_term, range%pn_factor)
     call parse_node_freeze_branch (range%pn_term)
     allocate (range%pn_expr)
     call parse_node_create_branch (range%pn_expr, &
          syntax_get_rule_ptr (syntax_cmd_list, var_str ("expr")))
     call parse_node_append_sub (range%pn_expr, range%pn_term)
     call parse_node_freeze_branch (range%pn_expr)
   end subroutine range_create_value_node
 
 @ %def range_create_value_node
 @ Compile, given an environment.
 <<Commands: range: TBP>>=
   procedure :: compile => range_compile
 <<Commands: procedures>>=
   subroutine range_compile (range, global)
     class(range_t), intent(inout) :: range
     type(rt_data_t), intent(in), target :: global
     type(var_list_t), pointer :: var_list
     var_list => global%get_var_list_ptr ()
     if (associated (range%pn_beg)) then
        call range%expr_beg%init_expr (range%pn_beg, var_list)
        if (associated (range%pn_end)) then
           call range%expr_end%init_expr (range%pn_end, var_list)
           if (associated (range%pn_step)) then
              call range%expr_step%init_expr (range%pn_step, var_list)
           end if
        end if
     end if
   end subroutine range_compile
 
 @ %def range_compile
 @ Evaluate: compute the actual bounds and parameters that determine the values
 that we can iterate.
 
 This is implementation-specific.
 <<Commands: range: TBP>>=
   procedure (range_evaluate), deferred :: evaluate
 <<Commands: interfaces>>=
   abstract interface
      subroutine range_evaluate (range)
        import
        class(range_t), intent(inout) :: range
      end subroutine range_evaluate
   end interface
 
 @ %def range_evaluate
 @ The version for an integer variable.  If the step is subtractive, we invert
 the sign and treat it as an additive step.  For a multiplicative step, the
 step must be greater than one, and the initial and final values must be of
 same sign and strictly ordered.  Analogously for a division step.
 <<Commands: range int: TBP>>=
   procedure :: evaluate => range_int_evaluate
 <<Commands: procedures>>=
   subroutine range_int_evaluate (range)
     class(range_int_t), intent(inout) :: range
     integer :: ival
     if (associated (range%pn_beg)) then
        call range%expr_beg%evaluate ()
        if (range%expr_beg%is_known ()) then
           range%i_beg = range%expr_beg%get_int ()
        else
           call range%write ()
           call msg_fatal &
                ("Range expression: initial value evaluates to unknown")
        end if
        if (associated (range%pn_end)) then
           call range%expr_end%evaluate ()
           if (range%expr_end%is_known ()) then
              range%i_end = range%expr_end%get_int ()
              if (associated (range%pn_step)) then
                 call range%expr_step%evaluate ()
                 if (range%expr_step%is_known ()) then
                    range%i_step = range%expr_step%get_int ()
                    select case (range%step_mode)
                    case (STEP_SUB);  range%i_step = - range%i_step
                    end select
                 else
                    call range%write ()
                    call msg_fatal &
                         ("Range expression: step value evaluates to unknown")
                 end if
              else
                 range%i_step = 1
              end if
           else
              call range%write ()
              call msg_fatal &
                   ("Range expression: final value evaluates to unknown")
           end if
        else
           range%i_end = range%i_beg
           range%i_step = 1
        end if
        select case (range%step_mode)
        case (STEP_NONE)
           range%n_step = 1
        case (STEP_ADD, STEP_SUB)
           if (range%i_step /= 0) then
              if (range%i_beg == range%i_end) then
                 range%n_step = 1
              else if (sign (1, range%i_end - range%i_beg) &
                   == sign (1, range%i_step)) then
                 range%n_step = (range%i_end - range%i_beg) / range%i_step + 1
              else
                 range%n_step = 0
              end if
           else
              call msg_fatal ("range evaluation (add): step value is zero")
           end if
        case (STEP_MUL)
           if (range%i_step > 1) then
              if (range%i_beg == range%i_end) then
                 range%n_step = 1
              else if (range%i_beg == 0) then
                 call msg_fatal ("range evaluation (mul): initial value is zero")
              else if (sign (1, range%i_beg) == sign (1, range%i_end) &
                   .and. abs (range%i_beg) < abs (range%i_end)) then
                 range%n_step = 0
                 ival = range%i_beg
                 do while (abs (ival) <= abs (range%i_end))
                    range%n_step = range%n_step + 1
                    ival = ival * range%i_step
                 end do
              else
                 range%n_step = 0
              end if
           else
              call msg_fatal &
                   ("range evaluation (mult): step value is one or less")
           end if
        case (STEP_DIV)
           if (range%i_step > 1) then
              if (range%i_beg == range%i_end) then
                 range%n_step = 1
              else if (sign (1, range%i_beg) == sign (1, range%i_end) &
                   .and. abs (range%i_beg) > abs (range%i_end)) then
                 range%n_step = 0
                 ival = range%i_beg
                 do while (abs (ival) >= abs (range%i_end))
                    range%n_step = range%n_step + 1
                    if (ival == 0)  exit
                    ival = ival / range%i_step
                 end do
              else
                 range%n_step = 0
              end if
           else
              call msg_fatal &
                   ("range evaluation (div): step value is one or less")
           end if
        case (STEP_COMP_ADD)
           call msg_fatal ("range evaluation: &
                &step mode /+/ not allowed for integer variable")
        case (STEP_COMP_MUL)
           call msg_fatal ("range evaluation: &
                &step mode /*/ not allowed for integer variable")
        case default
           call range%write ()
           call msg_bug ("range evaluation: step mode not implemented")
        end select
     end if
   end subroutine range_int_evaluate
 
 @ %def range_int_evaluate
 @ The version for a real variable.
 <<Commands: range real: TBP>>=
   procedure :: evaluate => range_real_evaluate
 <<Commands: procedures>>=
   subroutine range_real_evaluate (range)
     class(range_real_t), intent(inout) :: range
     if (associated (range%pn_beg)) then
        call range%expr_beg%evaluate ()
        if (range%expr_beg%is_known ()) then
           range%r_beg = range%expr_beg%get_real ()
        else
           call range%write ()
           call msg_fatal &
                ("Range expression: initial value evaluates to unknown")
        end if
        if (associated (range%pn_end)) then
           call range%expr_end%evaluate ()
           if (range%expr_end%is_known ()) then
              range%r_end = range%expr_end%get_real ()
              if (associated (range%pn_step)) then
                 if (range%expr_step%is_known ()) then
                    select case (range%step_mode)
                    case (STEP_ADD, STEP_SUB, STEP_MUL, STEP_DIV)
                       call range%expr_step%evaluate ()
                       range%r_step = range%expr_step%get_real ()
                       select case (range%step_mode)
                       case (STEP_SUB);  range%r_step = - range%r_step
                       end select
                    case (STEP_COMP_ADD, STEP_COMP_MUL)
                       range%n_step = &
                            max (range%expr_step%get_int (), 0)
                    end select
                 else
                    call range%write ()
                    call msg_fatal &
                         ("Range expression: step value evaluates to unknown")
                 end if
              else
                 call range%write ()
                 call msg_fatal &
                      ("Range expression (real): step value must be provided")
              end if
           else
              call range%write ()
              call msg_fatal &
                   ("Range expression: final value evaluates to unknown")
           end if
        else
           range%r_end = range%r_beg
           range%r_step = 1
        end if
        select case (range%step_mode)
        case (STEP_NONE)
           range%n_step = 1
        case (STEP_ADD, STEP_SUB)
           if (range%r_step /= 0) then
              if (sign (1._default, range%r_end - range%r_beg) &
                   == sign (1._default, range%r_step)) then
                 range%n_step = &
                      nint ((range%r_end - range%r_beg) / range%r_step + 1)
              else
                 range%n_step = 0
              end if
           else
              call msg_fatal ("range evaluation (add): step value is zero")
           end if
        case (STEP_MUL)
           if (range%r_step > 1) then
              if (range%r_beg == 0 .or. range%r_end == 0) then
                 call msg_fatal ("range evaluation (mul): bound is zero")
              else if (sign (1._default, range%r_beg) &
                   == sign (1._default, range%r_end) &
                   .and. abs (range%r_beg) <= abs (range%r_end)) then
                 range%lr_beg = log (abs (range%r_beg))
                 range%lr_end = log (abs (range%r_end))
                 range%lr_step = log (range%r_step)
                 range%n_step = nint &
                      (abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1)
              else
                 range%n_step = 0
              end if
           else
              call msg_fatal &
                   ("range evaluation (mult): step value is one or less")
           end if
        case (STEP_DIV)
           if (range%r_step > 1) then
              if (range%r_beg == 0 .or. range%r_end == 0) then
                 call msg_fatal ("range evaluation (div): bound is zero")
              else if (sign (1._default, range%r_beg) &
                   == sign (1._default, range%r_end) &
                   .and. abs (range%r_beg) >= abs (range%r_end)) then
                 range%lr_beg = log (abs (range%r_beg))
                 range%lr_end = log (abs (range%r_end))
                 range%lr_step = -log (range%r_step)
                 range%n_step = nint &
                      (abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1)
              else
                 range%n_step = 0
              end if
           else
              call msg_fatal &
                   ("range evaluation (mult): step value is one or less")
           end if
        case (STEP_COMP_ADD)
           ! Number of steps already known
        case (STEP_COMP_MUL)
           ! Number of steps already known
           if (range%r_beg == 0 .or. range%r_end == 0) then
              call msg_fatal ("range evaluation (mul): bound is zero")
           else if (sign (1._default, range%r_beg) &
                == sign (1._default, range%r_end)) then
              range%lr_beg = log (abs (range%r_beg))
              range%lr_end = log (abs (range%r_end))
           else
              range%n_step = 0
           end if
        case default
           call range%write ()
           call msg_bug ("range evaluation: step mode not implemented")
        end select
     end if
   end subroutine range_real_evaluate
 
 @ %def range_real_evaluate
 @ Return the number of iterations:
 <<Commands: range: TBP>>=
   procedure :: get_n_iterations => range_get_n_iterations
 <<Commands: procedures>>=
   function range_get_n_iterations (range) result (n)
     class(range_t), intent(in) :: range
     integer :: n
     n = range%n_step
   end function range_get_n_iterations
 
 @ %def range_get_n_iterations
 @ Compute the value for iteration [[i]] and store it in the embedded token.
 <<Commands: range: TBP>>=
   procedure (range_set_value), deferred :: set_value
 <<Commands: interfaces>>=
   abstract interface
      subroutine range_set_value (range, i)
        import
        class(range_t), intent(inout) :: range
        integer, intent(in) :: i
      end subroutine range_set_value
   end interface
 
 @ %def range_set_value
 @ In the integer case, we compute the value directly for additive step.  For
 multiplicative step, we perform a loop in the same way as above, where the
 number of iteration was determined.
 <<Commands: range int: TBP>>=
   procedure :: set_value => range_int_set_value
 <<Commands: procedures>>=
   subroutine range_int_set_value (range, i)
     class(range_int_t), intent(inout) :: range
     integer, intent(in) :: i
     integer :: k, ival
     select case (range%step_mode)
     case (STEP_NONE)
        ival = range%i_beg
     case (STEP_ADD, STEP_SUB)
        ival = range%i_beg + (i - 1) * range%i_step
     case (STEP_MUL)
        ival = range%i_beg
        do k = 1, i - 1
           ival = ival * range%i_step
        end do
     case (STEP_DIV)
        ival = range%i_beg
        do k = 1, i - 1
           ival = ival / range%i_step
        end do
     case default
        call range%write ()
        call msg_bug ("range iteration: step mode not implemented")
     end select
     call parse_node_set_value (range%pn_literal, ival = ival)
   end subroutine range_int_set_value
 
 @ %def range_int_set_value
 @ In the integer case, we compute the value directly for additive step.  For
 multiplicative step, we perform a loop in the same way as above, where the
 number of iteration was determined.
 <<Commands: range real: TBP>>=
   procedure :: set_value => range_real_set_value
 <<Commands: procedures>>=
   subroutine range_real_set_value (range, i)
     class(range_real_t), intent(inout) :: range
     integer, intent(in) :: i
     real(default) :: rval, x
     select case (range%step_mode)
     case (STEP_NONE)
        rval = range%r_beg
     case (STEP_ADD, STEP_SUB, STEP_COMP_ADD)
        if (range%n_step > 1) then
           x = real (i - 1, default) / (range%n_step - 1)
        else
           x = 1._default / 2
        end if
        rval = x * range%r_end + (1 - x) * range%r_beg
     case (STEP_MUL, STEP_DIV, STEP_COMP_MUL)
        if (range%n_step > 1) then
           x = real (i - 1, default) / (range%n_step - 1)
        else
           x = 1._default / 2
        end if
        rval = sign &
             (exp (x * range%lr_end + (1 - x) * range%lr_beg), range%r_beg)
     case default
        call range%write ()
        call msg_bug ("range iteration: step mode not implemented")
     end select
     call parse_node_set_value (range%pn_literal, rval = rval)
   end subroutine range_real_set_value
 
 @ %def range_real_set_value
 @
 \subsubsection{Scan over parameters and other objects}
 The scan command allocates a new parse node for the variable
 assignment (the lhs).  The rhs of this parse node is assigned from the
 available rhs expressions in the scan list, one at a time, so the
 compiled parse node can be prepended to the scan body.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_scan_t
      private
      type(string_t) :: name
      integer :: n_values = 0
      type(parse_node_p), dimension(:), allocatable :: scan_cmd
      class(range_t), dimension(:), allocatable :: range
    contains
    <<Commands: cmd scan: TBP>>
   end type cmd_scan_t
 
 @ %def cmd_scan_t
 @ Finalizer.
 
 The auxiliary parse nodes that we have constructed have to be treated
 carefully: the embedded pointers all point to persistent objects
 somewhere else and should not be finalized, so we should not call the
 finalizer recursively.
 <<Commands: cmd scan: TBP>>=
   procedure :: final => cmd_scan_final
 <<Commands: procedures>>=
   recursive subroutine cmd_scan_final (cmd)
     class(cmd_scan_t), intent(inout) :: cmd
     type(parse_node_t), pointer :: pn_var_single, pn_decl_single
     type(string_t) :: key
     integer :: i
     if (allocated (cmd%scan_cmd)) then
        do i = 1, size (cmd%scan_cmd)
           pn_var_single => parse_node_get_sub_ptr (cmd%scan_cmd(i)%ptr)
           key = parse_node_get_rule_key (pn_var_single)
           select case (char (key))
           case ("scan_string_decl", "scan_log_decl")
              pn_decl_single => parse_node_get_sub_ptr (pn_var_single, 2)
              call parse_node_final (pn_decl_single, recursive=.false.)
              deallocate (pn_decl_single)
           end select
           call parse_node_final (pn_var_single, recursive=.false.)
           deallocate (pn_var_single)
        end do
        deallocate (cmd%scan_cmd)
     end if
     if (allocated (cmd%range)) then
        do i = 1, size (cmd%range)
           call cmd%range(i)%final ()
        end do
     end if
   end subroutine cmd_scan_final
 
 @ %def cmd_scan_final
 @ Output.
 <<Commands: cmd scan: TBP>>=
   procedure :: write => cmd_scan_write
 <<Commands: procedures>>=
   subroutine cmd_scan_write (cmd, unit, indent)
     class(cmd_scan_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,1x,A,1x,'(',I0,')')")  "scan:", char (cmd%name), &
          cmd%n_values
   end subroutine cmd_scan_write
 
 @ %def cmd_scan_write
 @ Compile the scan command.  We construct a new parse node that
 implements the variable assignment for a single element on the rhs,
 instead of the whole list that we get from the original parse tree.
 By simply copying the node, we copy all pointers and inherit the
 targets from the original.  During execution, we should replace the
 rhs by the stored rhs pointers (the list elements), one by one, then
 (re)compile the redefined node.
 <<Commands: cmd scan: TBP>>=
   procedure :: compile => cmd_scan_compile
 <<Commands: procedures>>=
   recursive subroutine cmd_scan_compile (cmd, global)
     class(cmd_scan_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     type(parse_node_t), pointer :: pn_var, pn_body, pn_body_first
     type(parse_node_t), pointer :: pn_decl, pn_name
     type(parse_node_t), pointer :: pn_arg, pn_scan_cmd, pn_rhs
     type(parse_node_t), pointer :: pn_decl_single, pn_var_single
     type(syntax_rule_t), pointer :: var_rule_decl, var_rule
     type(string_t) :: key
     integer :: var_type
     integer :: i
     if (debug_on) call msg_debug (D_CORE, "cmd_scan_compile")
     if (debug_active (D_CORE))  call parse_node_write_rec (cmd%pn)
     pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
     pn_body => parse_node_get_next_ptr (pn_var)
     if (associated (pn_body)) then
        pn_body_first => parse_node_get_sub_ptr (pn_body)
     else
        pn_body_first => null ()
     end if
     key = parse_node_get_rule_key (pn_var)
     select case (char (key))
     case ("scan_num")
        pn_name => parse_node_get_sub_ptr (pn_var)
        cmd%name = parse_node_get_string (pn_name)
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_num"))
        pn_arg => parse_node_get_next_ptr (pn_name, 2)
     case ("scan_int")
        pn_name => parse_node_get_sub_ptr (pn_var, 2)
        cmd%name = parse_node_get_string (pn_name)
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_int"))
        pn_arg => parse_node_get_next_ptr (pn_name, 2)
     case ("scan_real")
        pn_name => parse_node_get_sub_ptr (pn_var, 2)
        cmd%name = parse_node_get_string (pn_name)
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_real"))
        pn_arg => parse_node_get_next_ptr (pn_name, 2)
     case ("scan_complex")
        pn_name => parse_node_get_sub_ptr (pn_var, 2)
        cmd%name = parse_node_get_string (pn_name)
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str("cmd_complex"))
        pn_arg => parse_node_get_next_ptr (pn_name, 2)
     case ("scan_alias")
        pn_name => parse_node_get_sub_ptr (pn_var, 2)
        cmd%name = parse_node_get_string (pn_name)
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_alias"))
        pn_arg => parse_node_get_next_ptr (pn_name, 2)
     case ("scan_string_decl")
        pn_decl => parse_node_get_sub_ptr (pn_var, 2)
        pn_name => parse_node_get_sub_ptr (pn_decl, 2)
        cmd%name = parse_node_get_string (pn_name)
        var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_string"))
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_string_decl"))
        pn_arg => parse_node_get_next_ptr (pn_name, 2)
     case ("scan_log_decl")
        pn_decl => parse_node_get_sub_ptr (pn_var, 2)
        pn_name => parse_node_get_sub_ptr (pn_decl, 2)
        cmd%name = parse_node_get_string (pn_name)
        var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_log"))
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_log_decl"))
        pn_arg => parse_node_get_next_ptr (pn_name, 2)
     case ("scan_cuts")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_cuts"))
        cmd%name = "cuts"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_weight")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_weight"))
        cmd%name = "weight"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_scale")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_scale"))
        cmd%name = "scale"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_ren_scale")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_ren_scale"))
        cmd%name = "renormalization_scale"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_fac_scale")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_fac_scale"))
        cmd%name = "factorization_scale"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_selection")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_selection"))
        cmd%name = "selection"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_reweight")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_reweight"))
        cmd%name = "reweight"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_analysis")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_analysis"))
        cmd%name = "analysis"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_model")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_model"))
        cmd%name = "model"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case ("scan_library")
        var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
             var_str ("cmd_library"))
        cmd%name = "library"
        pn_arg => parse_node_get_sub_ptr (pn_var, 3)
     case default
        call msg_bug ("scan: case '" // char (key) // "' not implemented")
     end select
     if (associated (pn_arg)) then
        cmd%n_values = parse_node_get_n_sub (pn_arg)
     end if
     var_list => global%get_var_list_ptr ()
     allocate (cmd%scan_cmd (cmd%n_values))
     select case (char (key))
     case ("scan_num")
        var_type = &
             var_list%get_type (cmd%name)
        select case (var_type)
        case (V_INT)
           allocate (range_int_t :: cmd%range (cmd%n_values))
        case (V_REAL)
           allocate (range_real_t :: cmd%range (cmd%n_values))
        case (V_CMPLX)
           call msg_fatal ("scan over complex variable not implemented")
        case (V_NONE)
           call msg_fatal ("scan: variable '" // char (cmd%name) //"' undefined")
        case default
           call msg_bug ("scan: impossible variable type")
        end select
     case ("scan_int")
        allocate (range_int_t :: cmd%range (cmd%n_values))
     case ("scan_real")
        allocate (range_real_t :: cmd%range (cmd%n_values))
     case ("scan_complex")
        call msg_fatal ("scan over complex variable not implemented")
     end select
     i = 1
     if (associated (pn_arg)) then
        pn_rhs => parse_node_get_sub_ptr (pn_arg)
     else
        pn_rhs => null ()
     end if
     do while (associated (pn_rhs))
        allocate (pn_scan_cmd)
        call parse_node_create_branch (pn_scan_cmd, &
             syntax_get_rule_ptr (syntax_cmd_list, var_str ("command_list")))
        allocate (pn_var_single)
        pn_var_single = pn_var
        call parse_node_replace_rule (pn_var_single, var_rule)
        select case (char (key))
        case ("scan_num", "scan_int", "scan_real", &
             "scan_complex", "scan_alias", &
             "scan_cuts", "scan_weight", &
             "scan_scale", "scan_ren_scale", "scan_fac_scale", &
             "scan_selection", "scan_reweight", "scan_analysis", &
             "scan_model", "scan_library")
           if (allocated (cmd%range)) then
              call cmd%range(i)%init (pn_rhs)
              call parse_node_replace_last_sub &
                   (pn_var_single, cmd%range(i)%pn_expr)
           else
              call parse_node_replace_last_sub (pn_var_single, pn_rhs)
           end if
        case ("scan_string_decl", "scan_log_decl")
           allocate (pn_decl_single)
           pn_decl_single = pn_decl
           call parse_node_replace_rule (pn_decl_single, var_rule_decl)
           call parse_node_replace_last_sub (pn_decl_single, pn_rhs)
           call parse_node_freeze_branch (pn_decl_single)
           call parse_node_replace_last_sub (pn_var_single, pn_decl_single)
        case default
           call msg_bug ("scan: case '" // char (key)  &
                // "' broken")
        end select
        call parse_node_freeze_branch (pn_var_single)
        call parse_node_append_sub (pn_scan_cmd, pn_var_single)
        call parse_node_append_sub (pn_scan_cmd, pn_body_first)
        call parse_node_freeze_branch (pn_scan_cmd)
        cmd%scan_cmd(i)%ptr => pn_scan_cmd
        i = i + 1
        pn_rhs => parse_node_get_next_ptr (pn_rhs)
     end do
     if (debug_active (D_CORE)) then
        do i = 1, cmd%n_values
           print *, "scan command ", i
           call parse_node_write_rec (cmd%scan_cmd(i)%ptr)
           if (allocated (cmd%range))  call cmd%range(i)%write ()
        end do
        print *, "original"
        call parse_node_write_rec (cmd%pn)
     end if
   end subroutine cmd_scan_compile
 
 @ %def cmd_scan_compile
 @ Execute the loop for all values in the step list.  We use the
 parse trees with single variable assignment that we have stored, to
 iteratively create a local environment, execute the stored commands, and
 destroy it again.  When we encounter a range object, we execute the commands
 for each value that this object provides.  Computing this value has the side
 effect of modifying the rhs of the variable assignment that heads the local
 command list, directly in the local parse tree.
 <<Commands: cmd scan: TBP>>=
   procedure :: execute => cmd_scan_execute
 <<Commands: procedures>>=
   recursive subroutine cmd_scan_execute (cmd, global)
     class(cmd_scan_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(rt_data_t), allocatable :: local
     integer :: i, j
     do i = 1, cmd%n_values
        if (allocated (cmd%range)) then
           call cmd%range(i)%compile (global)
           call cmd%range(i)%evaluate ()
           do j = 1, cmd%range(i)%get_n_iterations ()
              call cmd%range(i)%set_value (j)
              allocate (local)
              call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr)
              call local%local_final ()
              deallocate (local)
           end do
        else
           allocate (local)
           call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr)
           call local%local_final ()
           deallocate (local)
        end if
     end do
   end subroutine cmd_scan_execute
 
 @ %def cmd_scan_execute
 @
 \subsubsection{Conditionals}
 Conditionals are implemented as a list that is compiled and evaluated
 recursively; this allows for a straightforward representation of
 [[else if]] constructs.  A [[cmd_if_t]] object can hold either an
 [[else_if]] clause which is another object of this type, or an
 [[else_body]], but not both.
 
 If- or else-bodies are no scoping units, so all data remain global and
 no copy-in copy-out is needed.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_if_t
      private
      type(parse_node_t), pointer :: pn_if_lexpr => null ()
      type(command_list_t), pointer :: if_body => null ()
      type(cmd_if_t), dimension(:), pointer :: elsif_cmd => null ()
      type(command_list_t), pointer :: else_body => null ()
    contains
    <<Commands: cmd if: TBP>>
   end type cmd_if_t
 
 @ %def cmd_if_t
 @ Finalizer.  There are no local options, therefore we can simply override
 the default finalizer.
 <<Commands: cmd if: TBP>>=
   procedure :: final => cmd_if_final
 <<Commands: procedures>>=
   recursive subroutine cmd_if_final (cmd)
     class(cmd_if_t), intent(inout) :: cmd
     integer :: i
     if (associated (cmd%if_body)) then
        call command_list_final (cmd%if_body)
        deallocate (cmd%if_body)
     end if
     if (associated (cmd%elsif_cmd)) then
        do i = 1, size (cmd%elsif_cmd)
           call cmd_if_final (cmd%elsif_cmd(i))
        end do
        deallocate (cmd%elsif_cmd)
     end if
     if (associated (cmd%else_body)) then
        call command_list_final (cmd%else_body)
        deallocate (cmd%else_body)
     end if
   end subroutine cmd_if_final
 
 @ %def cmd_if_final
 @ Output.  Recursively write the command lists.
 <<Commands: cmd if: TBP>>=
   procedure :: write => cmd_if_write
 <<Commands: procedures>>=
   subroutine cmd_if_write (cmd, unit, indent)
     class(cmd_if_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, ind, i
     u = given_output_unit (unit);  if (u < 0)  return
     ind = 0;  if (present (indent))  ind = indent
     call write_indent (u, indent)
     write (u, "(A)")  "if <expr> then"
     if (associated (cmd%if_body)) then
        call cmd%if_body%write (unit, ind + 1)
     end if
     if (associated (cmd%elsif_cmd)) then
        do i = 1, size (cmd%elsif_cmd)
           call write_indent (u, indent)
           write (u, "(A)")  "elsif <expr> then"
           if (associated (cmd%elsif_cmd(i)%if_body)) then
              call cmd%elsif_cmd(i)%if_body%write (unit, ind + 1)
           end if
        end do
     end if
     if (associated (cmd%else_body)) then
        call write_indent (u, indent)
        write (u, "(A)")  "else"
        call cmd%else_body%write (unit, ind + 1)
     end if
   end subroutine cmd_if_write
 
 @ %def cmd_if_write
 @ Compile the conditional.
 <<Commands: cmd if: TBP>>=
   procedure :: compile => cmd_if_compile
 <<Commands: procedures>>=
   recursive subroutine cmd_if_compile (cmd, global)
     class(cmd_if_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_lexpr, pn_body
     type(parse_node_t), pointer :: pn_elsif_clauses, pn_cmd_elsif
     type(parse_node_t), pointer :: pn_else_clause, pn_cmd_else
     integer :: i, n_elsif
     pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 2)
     cmd%pn_if_lexpr => pn_lexpr
     pn_body => parse_node_get_next_ptr (pn_lexpr, 2)
     select case (char (parse_node_get_rule_key (pn_body)))
     case ("command_list")
        allocate (cmd%if_body)
        call cmd%if_body%compile (pn_body, global)
        pn_elsif_clauses => parse_node_get_next_ptr (pn_body)
     case default
        pn_elsif_clauses => pn_body
     end select
     select case (char (parse_node_get_rule_key (pn_elsif_clauses)))
     case ("elsif_clauses")
        n_elsif = parse_node_get_n_sub (pn_elsif_clauses)
        allocate (cmd%elsif_cmd (n_elsif))
        pn_cmd_elsif => parse_node_get_sub_ptr (pn_elsif_clauses)
        do i = 1, n_elsif
           pn_lexpr => parse_node_get_sub_ptr (pn_cmd_elsif, 2)
           cmd%elsif_cmd(i)%pn_if_lexpr => pn_lexpr
           pn_body => parse_node_get_next_ptr (pn_lexpr, 2)
           if (associated (pn_body)) then
              allocate (cmd%elsif_cmd(i)%if_body)
              call cmd%elsif_cmd(i)%if_body%compile (pn_body, global)
           end if
           pn_cmd_elsif => parse_node_get_next_ptr (pn_cmd_elsif)
        end do
        pn_else_clause => parse_node_get_next_ptr (pn_elsif_clauses)
     case default
        pn_else_clause => pn_elsif_clauses
     end select
     select case (char (parse_node_get_rule_key (pn_else_clause)))
     case ("else_clause")
        pn_cmd_else => parse_node_get_sub_ptr (pn_else_clause)
        pn_body => parse_node_get_sub_ptr (pn_cmd_else, 2)
        if (associated (pn_body)) then
           allocate (cmd%else_body)
           call cmd%else_body%compile (pn_body, global)
        end if
     end select
   end subroutine cmd_if_compile
 
 @ %def global
 @ (Recursively) execute the condition.  Context remains global in all cases.
 <<Commands: cmd if: TBP>>=
   procedure :: execute => cmd_if_execute
 <<Commands: procedures>>=
   recursive subroutine cmd_if_execute (cmd, global)
     class(cmd_if_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     logical :: lval, is_known
     integer :: i
     var_list => global%get_var_list_ptr ()
     lval = eval_log (cmd%pn_if_lexpr, var_list, is_known=is_known)
     if (is_known) then
        if (lval) then
           if (associated (cmd%if_body)) then
              call cmd%if_body%execute (global)
           end if
           return
        end if
     else
        call error_undecided ()
        return
     end if
     if (associated (cmd%elsif_cmd)) then
        SCAN_ELSIF: do i = 1, size (cmd%elsif_cmd)
           lval = eval_log (cmd%elsif_cmd(i)%pn_if_lexpr, var_list, &
                 is_known=is_known)
           if (is_known) then
              if (lval) then
                 if (associated (cmd%elsif_cmd(i)%if_body)) then
                    call cmd%elsif_cmd(i)%if_body%execute (global)
                 end if
                 return
              end if
           else
              call error_undecided ()
              return
           end if
        end do SCAN_ELSIF
     end if
     if (associated (cmd%else_body)) then
        call cmd%else_body%execute (global)
     end if
   contains
     subroutine error_undecided ()
       call msg_error ("Undefined result of cmditional expression: " &
            // "neither branch will be executed")
     end subroutine error_undecided
   end subroutine cmd_if_execute
 
 @ %def cmd_if_execute
 @
 \subsubsection{Include another command-list file}
 The include command allocates a local parse tree.  This must not be
 deleted before the command object itself is deleted, since pointers
 may point to subobjects of it.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_include_t
      private
      type(string_t) :: file
      type(command_list_t), pointer :: command_list => null ()
      type(parse_tree_t) :: parse_tree
    contains
    <<Commands: cmd include: TBP>>
   end type cmd_include_t
 
 @ %def cmd_include_t
 @ Finalizer: delete the command list.  No options, so we can simply override
 the default finalizer.
 <<Commands: cmd include: TBP>>=
   procedure :: final => cmd_include_final
 <<Commands: procedures>>=
   subroutine cmd_include_final (cmd)
     class(cmd_include_t), intent(inout) :: cmd
     call parse_tree_final (cmd%parse_tree)
     if (associated (cmd%command_list)) then
        call cmd%command_list%final ()
        deallocate (cmd%command_list)
     end if
   end subroutine cmd_include_final
 
 @ %def cmd_include_final
 @ Write: display the command list as-is, if allocated.
 <<Commands: cmd include: TBP>>=
   procedure :: write => cmd_include_write
 <<Commands: procedures>>=
   subroutine cmd_include_write (cmd, unit, indent)
     class(cmd_include_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, ind
     u = given_output_unit (unit)
     ind = 0;  if (present (indent))  ind = indent
     call write_indent (u, indent)
     write (u, "(A,A,A,A)")  "include ", '"', char (cmd%file), '"'
     if (associated (cmd%command_list)) then
        call cmd%command_list%write (u, ind + 1)
     end if
   end subroutine cmd_include_write
 
 @ %def cmd_include_write
 @ Compile file contents: First parse the file, then immediately
 compile its contents.  Use the global data set.
 <<Commands: cmd include: TBP>>=
   procedure :: compile => cmd_include_compile
 <<Commands: procedures>>=
   subroutine cmd_include_compile (cmd, global)
     class(cmd_include_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg, pn_file
     type(string_t) :: file
     logical :: exist
     integer :: u
     type(stream_t), target :: stream
     type(lexer_t) :: lexer
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
     pn_file => parse_node_get_sub_ptr (pn_arg)
     file = parse_node_get_string (pn_file)
     inquire (file=char(file), exist=exist)
     if (exist) then
        cmd%file = file
     else
        cmd%file = global%os_data%whizard_cutspath // "/" // file
        inquire (file=char(cmd%file), exist=exist)
        if (.not. exist) then
           call msg_error ("Include file '" // char (file) // "' not found")
           return
        end if
     end if
     u = free_unit ()
     call lexer_init_cmd_list (lexer, global%lexer)
     call stream_init (stream, char (cmd%file))
     call lexer_assign_stream (lexer, stream)
     call parse_tree_init (cmd%parse_tree, syntax_cmd_list, lexer)
     call stream_final (stream)
     call lexer_final (lexer)
     close (u)
     allocate (cmd%command_list)
     call cmd%command_list%compile (cmd%parse_tree%get_root_ptr (), &
          global)
   end subroutine cmd_include_compile
 
 @ %def cmd_include_compile
 @ Execute file contents in the global context.
 <<Commands: cmd include: TBP>>=
   procedure :: execute => cmd_include_execute
 <<Commands: procedures>>=
   subroutine cmd_include_execute (cmd, global)
     class(cmd_include_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     if (associated (cmd%command_list)) then
        call msg_message &
             ("Including Sindarin from '" // char (cmd%file) // "'")
        call cmd%command_list%execute (global)
        call msg_message &
             ("End of included '" // char (cmd%file) // "'")
     end if
   end subroutine cmd_include_execute
 
 @ %def cmd_include_execute
 @
 \subsubsection{Export values}
 This command exports the current values of variables or other objects to the
 surrounding scope.  By default, a scope enclosed by braces keeps all objects
 local to it.  The [[export]] command exports the values that are generated
 within the scope to the corresponding object in the outer scope.
 
 The allowed set of exportable objects is, in principle, the same as the set of
 objects that the [[show]] command supports.  This includes some convenience
 abbreviations.
 
 TODO: The initial implementation inherits syntax from [[show]], but supports
 only the [[results]] pseudo-object.  The results (i.e., the process stack) is
 appended to the outer process stack instead of being discarded.  The behavior
 of the [[export]] command for other object kinds is to be defined on a
 case-by-case basis.  It may involve replacing the outer value or, instead,
 doing some sort of appending or reduction.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_export_t
      private
      type(string_t), dimension(:), allocatable :: name
    contains
    <<Commands: cmd export: TBP>>
   end type cmd_export_t
 
 @ %def cmd_export_t
 @ Output: list the object names, not values.
 <<Commands: cmd export: TBP>>=
   procedure :: write => cmd_export_write
 <<Commands: procedures>>=
   subroutine cmd_export_write (cmd, unit, indent)
     class(cmd_export_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A)", advance="no")  "export: "
     if (allocated (cmd%name)) then
        do i = 1, size (cmd%name)
           write (u, "(1x,A)", advance="no")  char (cmd%name(i))
        end do
        write (u, *)
     else
        write (u, "(5x,A)")  "[undefined]"
     end if
   end subroutine cmd_export_write
 
 @ %def cmd_export_write
 @ Compile.  Allocate an array which is filled with the names of the
 variables to export.
 <<Commands: cmd export: TBP>>=
   procedure :: compile => cmd_export_compile
 <<Commands: procedures>>=
   subroutine cmd_export_compile (cmd, global)
     class(cmd_export_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
     type(string_t) :: key
     integer :: i, n_args
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
     if (associated (pn_arg)) then
        select case (char (parse_node_get_rule_key (pn_arg)))
        case ("show_arg")
           cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
        case default
           cmd%pn_opt => pn_arg
           pn_arg => null ()
        end select
     end if
     call cmd%compile_options (global)
     if (associated (pn_arg)) then
        n_args = parse_node_get_n_sub (pn_arg)
        allocate (cmd%name (n_args))
        pn_var => parse_node_get_sub_ptr (pn_arg)
        i = 0
        do while (associated (pn_var))
           i = i + 1
           select case (char (parse_node_get_rule_key (pn_var)))
           case ("model", "library", "beams", "iterations", &
                 "cuts", "weight", "int", "real", "complex", &
                 "scale", "factorization_scale", "renormalization_scale", &
                 "selection", "reweight", "analysis", "pdg", &
                 "stable", "unstable", "polarized", "unpolarized", &
                 "results", "expect", "intrinsic", "string", "logical")
              cmd%name(i) = parse_node_get_key (pn_var)
           case ("result_var")
              pn_prefix => parse_node_get_sub_ptr (pn_var)
              pn_name => parse_node_get_next_ptr (pn_prefix)
              if (associated (pn_name)) then
                 cmd%name(i) = parse_node_get_key (pn_prefix) &
                      // "(" // parse_node_get_string (pn_name) // ")"
              else
                 cmd%name(i) = parse_node_get_key (pn_prefix)
              end if
           case ("log_var", "string_var", "alias_var")
              pn_prefix => parse_node_get_sub_ptr (pn_var)
              pn_name => parse_node_get_next_ptr (pn_prefix)
              key = parse_node_get_key (pn_prefix)
              if (associated (pn_name)) then
                 select case (char (parse_node_get_rule_key (pn_name)))
                 case ("var_name")
                    select case (char (key))
                    case ("?", "$")  ! $ sign
                       cmd%name(i) = key // parse_node_get_string (pn_name)
                    case ("alias")
                       cmd%name(i) = parse_node_get_string (pn_name)
                    end select
                 case default
                    call parse_node_mismatch &
                         ("var_name",  pn_name)
                 end select
              else
                 cmd%name(i) = key
              end if
           case default
              cmd%name(i) = parse_node_get_string (pn_var)
           end select
           !!! restriction imposed by current lack of implementation
           select case (char (parse_node_get_rule_key (pn_var)))
           case ("results")
           case default
              call msg_fatal ("export: object (type) '" &
                   // char (parse_node_get_rule_key (pn_var)) &
                   // "' not supported yet")
           end select
           pn_var => parse_node_get_next_ptr (pn_var)
        end do
     else
        allocate (cmd%name (0))
     end if
   end subroutine cmd_export_compile
 
 @ %def cmd_export_compile
 @ Execute.  Scan the list of objects to export.
 <<Commands: cmd export: TBP>>=
   procedure :: execute => cmd_export_execute
 <<Commands: procedures>>=
   subroutine cmd_export_execute (cmd, global)
     class(cmd_export_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     call global%append_exports (cmd%name)
   end subroutine cmd_export_execute
 
 @ %def cmd_export_execute
 @
 \subsubsection{Quit command execution}
 The code is the return code of the whole program if it is terminated
 by this command.
 <<Commands: types>>=
   type, extends (command_t) :: cmd_quit_t
      private
      logical :: has_code = .false.
      type(parse_node_t), pointer :: pn_code_expr => null ()
    contains
    <<Commands: cmd quit: TBP>>
   end type cmd_quit_t
 
 @ %def cmd_quit_t
 @ Output.
 <<Commands: cmd quit: TBP>>=
   procedure :: write => cmd_quit_write
 <<Commands: procedures>>=
   subroutine cmd_quit_write (cmd, unit, indent)
     class(cmd_quit_t), intent(in) :: cmd
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write (u, "(1x,A,L1)")  "quit: has_code = ", cmd%has_code
   end subroutine cmd_quit_write
 
 @ %def cmd_quit_write
 @ Compile: allocate a [[quit]] object which serves as a placeholder.
 <<Commands: cmd quit: TBP>>=
   procedure :: compile => cmd_quit_compile
 <<Commands: procedures>>=
   subroutine cmd_quit_compile (cmd, global)
     class(cmd_quit_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_arg
     pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
     if (associated (pn_arg)) then
        cmd%pn_code_expr => parse_node_get_sub_ptr (pn_arg)
        cmd%has_code = .true.
     end if
   end subroutine cmd_quit_compile
 
 @ %def cmd_quit_compile
 @ Execute: The quit command does not execute anything, it just stops
 command execution.  This is achieved by setting quit flag and quit
 code in the global variable list.  However, the return code, if
 present, is an expression which has to be evaluated.
 <<Commands: cmd quit: TBP>>=
   procedure :: execute => cmd_quit_execute
 <<Commands: procedures>>=
   subroutine cmd_quit_execute (cmd, global)
     class(cmd_quit_t), intent(inout) :: cmd
     type(rt_data_t), intent(inout), target :: global
     type(var_list_t), pointer :: var_list
     logical :: is_known
     var_list => global%get_var_list_ptr ()
     if (cmd%has_code) then
        global%quit_code = eval_int (cmd%pn_code_expr, var_list, &
             is_known=is_known)
        if (.not. is_known) then
           call msg_error ("Undefined return code of quit/exit command")
        end if
     end if
     global%quit = .true.
   end subroutine cmd_quit_execute
 
 @ %def cmd_quit_execute
 @
 \subsection{The command list}
 The command list holds a list of commands and relevant global data.
 <<Commands: public>>=
   public :: command_list_t
 <<Commands: types>>=
   type :: command_list_t
      ! not private anymore as required by the whizard-c-interface
      class(command_t), pointer :: first => null ()
      class(command_t), pointer :: last => null ()
    contains
    <<Commands: command list: TBP>>
   end type command_list_t
 
 @ %def command_list_t
 @ Output.
 <<Commands: command list: TBP>>=
   procedure :: write => command_list_write
 <<Commands: procedures>>=
   recursive subroutine command_list_write (cmd_list, unit, indent)
     class(command_list_t), intent(in) :: cmd_list
     integer, intent(in), optional :: unit, indent
     class(command_t), pointer :: cmd
     cmd => cmd_list%first
     do while (associated (cmd))
        call cmd%write (unit, indent)
        cmd => cmd%next
     end do
   end subroutine command_list_write
 
 @ %def command_list_write
 @ Append a new command to the list and free the original pointer.
 <<Commands: command list: TBP>>=
   procedure :: append => command_list_append
 <<Commands: procedures>>=
   subroutine command_list_append (cmd_list, command)
     class(command_list_t), intent(inout) :: cmd_list
     class(command_t), intent(inout), pointer :: command
     if (associated (cmd_list%last)) then
        cmd_list%last%next => command
     else
        cmd_list%first => command
     end if
     cmd_list%last => command
     command => null ()
   end subroutine command_list_append
 
 @ %def command_list_append
 @ Finalize.
 <<Commands: command list: TBP>>=
   procedure :: final => command_list_final
 <<Commands: procedures>>=
   recursive subroutine command_list_final (cmd_list)
     class(command_list_t), intent(inout) :: cmd_list
     class(command_t), pointer :: command
     do while (associated (cmd_list%first))
        command => cmd_list%first
        cmd_list%first => cmd_list%first%next
        call command%final ()
        deallocate (command)
     end do
     cmd_list%last => null ()
   end subroutine command_list_final
 
 @ %def command_list_final
 @
 \subsection{Compiling the parse tree}
 Transform a parse tree into a command list.  Initialization is assumed
 to be done.
 
 After each command, we set a breakpoint.
 <<Commands: command list: TBP>>=
   procedure :: compile => command_list_compile
 <<Commands: procedures>>=
   recursive subroutine command_list_compile (cmd_list, pn, global)
     class(command_list_t), intent(inout), target :: cmd_list
     type(parse_node_t), intent(in), target :: pn
     type(rt_data_t), intent(inout), target :: global
     type(parse_node_t), pointer :: pn_cmd
     class(command_t), pointer :: command
     integer :: i
     pn_cmd => parse_node_get_sub_ptr (pn)
     do i = 1, parse_node_get_n_sub (pn)
        call dispatch_command (command, pn_cmd)
        call command%compile (global)
        call cmd_list%append (command)
        call terminate_now_if_signal ()
        pn_cmd => parse_node_get_next_ptr (pn_cmd)
     end do
   end subroutine command_list_compile
 
 @ %def command_list_compile
 @
 \subsection{Executing the command list}
 Before executing a command we should execute its options (if any).  After
 that, reset the options, i.e., remove temporary effects from the global
 state.
 
 Also here, after each command we set a breakpoint.
 <<Commands: command list: TBP>>=
   procedure :: execute => command_list_execute
 <<Commands: procedures>>=
   recursive subroutine command_list_execute (cmd_list, global)
     class(command_list_t), intent(in) :: cmd_list
     type(rt_data_t), intent(inout), target :: global
     class(command_t), pointer :: command
     command => cmd_list%first
     COMMAND_COND: do while (associated (command))
        call command%execute_options (global)
        call command%execute (global)
        call command%reset_options (global)
        call terminate_now_if_signal ()
        if (global%quit)  exit COMMAND_COND
        command => command%next
     end do COMMAND_COND
   end subroutine command_list_execute
 
 @ %def command_list_execute
 @
 \subsection{Command list syntax}
 <<Commands: public>>=
   public :: syntax_cmd_list
 <<Commands: variables>>=
   type(syntax_t), target, save :: syntax_cmd_list
 
 @ %def syntax_cmd_list
 <<Commands: public>>=
   public :: syntax_cmd_list_init
 <<Commands: procedures>>=
   subroutine syntax_cmd_list_init ()
     type(ifile_t) :: ifile
     call define_cmd_list_syntax (ifile)
     call syntax_init (syntax_cmd_list, ifile)
     call ifile_final (ifile)
   end subroutine syntax_cmd_list_init
 
 @ %def syntax_cmd_list_init
 <<Commands: public>>=
   public :: syntax_cmd_list_final
 <<Commands: procedures>>=
   subroutine syntax_cmd_list_final ()
     call syntax_final (syntax_cmd_list)
   end subroutine syntax_cmd_list_final
 
 @ %def syntax_cmd_list_final
 <<Commands: public>>=
   public :: syntax_cmd_list_write
 <<Commands: procedures>>=
   subroutine syntax_cmd_list_write (unit)
     integer, intent(in), optional :: unit
     call syntax_write (syntax_cmd_list, unit)
   end subroutine syntax_cmd_list_write
 
 @ %def syntax_cmd_list_write
 <<Commands: procedures>>=
   subroutine define_cmd_list_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "SEQ command_list = command*")
     call ifile_append (ifile, "ALT command = " &
          // "cmd_model | cmd_library | cmd_iterations | cmd_sample_format | " &
          // "cmd_var | cmd_slha | " &
          // "cmd_show | cmd_clear | " &
          // "cmd_expect | " &
          // "cmd_cuts | cmd_scale | cmd_fac_scale | cmd_ren_scale | " &
          // "cmd_weight | cmd_selection | cmd_reweight | " &
          // "cmd_beams | cmd_beams_pol_density | cmd_beams_pol_fraction | " &
          // "cmd_beams_momentum | cmd_beams_theta | cmd_beams_phi | " &
          // "cmd_integrate | " &
          // "cmd_observable | cmd_histogram | cmd_plot | cmd_graph | " &
          // "cmd_record | " &
          // "cmd_analysis | cmd_alt_setup | " &
          // "cmd_unstable | cmd_stable | cmd_simulate | cmd_rescan | " &
          // "cmd_process | cmd_compile | cmd_exec | " &
          // "cmd_scan | cmd_if | cmd_include | cmd_quit | " &
          // "cmd_export | " &
          // "cmd_polarized | cmd_unpolarized | " &
          // "cmd_open_out | cmd_close_out | cmd_printf | " &
          // "cmd_write_analysis | cmd_compile_analysis | cmd_nlo | cmd_components")
     call ifile_append (ifile, "GRO options = '{' local_command_list '}'")
     call ifile_append (ifile, "SEQ local_command_list = local_command*")
     call ifile_append (ifile, "ALT local_command = " &
          // "cmd_model | cmd_library | cmd_iterations | cmd_sample_format | " &
          // "cmd_var | cmd_slha | " &
          // "cmd_show | " &
          // "cmd_expect | " &
          // "cmd_cuts | cmd_scale | cmd_fac_scale | cmd_ren_scale | " &
          // "cmd_weight | cmd_selection | cmd_reweight | " &
          // "cmd_beams | cmd_beams_pol_density | cmd_beams_pol_fraction | " &
          // "cmd_beams_momentum | cmd_beams_theta | cmd_beams_phi | " &
          // "cmd_observable | cmd_histogram | cmd_plot | cmd_graph | " &
          // "cmd_clear | cmd_record | " &
          // "cmd_analysis | cmd_alt_setup | " &
          // "cmd_open_out | cmd_close_out | cmd_printf | " &
          // "cmd_write_analysis | cmd_compile_analysis | cmd_nlo | cmd_components")
     call ifile_append (ifile, "SEQ cmd_model = model '=' model_name model_arg?")
     call ifile_append (ifile, "KEY model")
     call ifile_append (ifile, "ALT model_name = model_id | string_literal")
     call ifile_append (ifile, "IDE model_id")
     call ifile_append (ifile, "ARG model_arg = ( model_scheme? )")
     call ifile_append (ifile, "ALT model_scheme = " &
          // "ufo_spec | scheme_id | string_literal")
     call ifile_append (ifile, "SEQ ufo_spec = ufo ufo_arg?")
     call ifile_append (ifile, "KEY ufo")
     call ifile_append (ifile, "ARG ufo_arg = ( string_literal )")
     call ifile_append (ifile, "IDE scheme_id")
     call ifile_append (ifile, "SEQ cmd_library = library '=' lib_name")
     call ifile_append (ifile, "KEY library")
     call ifile_append (ifile, "ALT lib_name = lib_id | string_literal")
     call ifile_append (ifile, "IDE lib_id")
     call ifile_append (ifile, "ALT cmd_var = " &
          // "cmd_log_decl | cmd_log | " &
          // "cmd_int | cmd_real | cmd_complex | cmd_num | " &
          // "cmd_string_decl | cmd_string | cmd_alias | " &
          // "cmd_result")
     call ifile_append (ifile, "SEQ cmd_log_decl = logical cmd_log")
     call ifile_append (ifile, "SEQ cmd_log = '?' var_name '=' lexpr")
     call ifile_append (ifile, "SEQ cmd_int = int var_name '=' expr")
     call ifile_append (ifile, "SEQ cmd_real = real var_name '=' expr")
     call ifile_append (ifile, "SEQ cmd_complex = complex var_name '=' expr")
     call ifile_append (ifile, "SEQ cmd_num = var_name '=' expr")
     call ifile_append (ifile, "SEQ cmd_string_decl = string cmd_string")
     call ifile_append (ifile, "SEQ cmd_string = " &
          // "'$' var_name '=' sexpr") ! $
     call ifile_append (ifile, "SEQ cmd_alias = alias var_name '=' cexpr")
     call ifile_append (ifile, "SEQ cmd_result = result '=' expr")
     call ifile_append (ifile, "SEQ cmd_slha = slha_action slha_arg options?")
     call ifile_append (ifile, "ALT slha_action = " &
          // "read_slha | write_slha")
     call ifile_append (ifile, "KEY read_slha")
     call ifile_append (ifile, "KEY write_slha")
     call ifile_append (ifile, "ARG slha_arg = ( string_literal )")
     call ifile_append (ifile, "SEQ cmd_show = show show_arg options?")
     call ifile_append (ifile, "KEY show")
     call ifile_append (ifile, "ARG show_arg = ( showable* )")
     call ifile_append (ifile, "ALT showable = " &
          // "model | library | beams | iterations | " &
          // "cuts | weight | logical | string | pdg | " &
          // "scale | factorization_scale | renormalization_scale | " &
    // "selection | reweight | analysis | " &
          // "stable | unstable | polarized | unpolarized | " &
          // "expect | intrinsic | int | real | complex | " &
          // "alias_var | string | results | result_var | " &
          // "log_var | string_var | var_name")
     call ifile_append (ifile, "KEY results")
     call ifile_append (ifile, "KEY intrinsic")
     call ifile_append (ifile, "SEQ alias_var = alias var_name")
     call ifile_append (ifile, "SEQ result_var = result_key result_arg?")
     call ifile_append (ifile, "SEQ log_var = '?' var_name")
     call ifile_append (ifile, "SEQ string_var = '$' var_name")  ! $
     call ifile_append (ifile, "SEQ cmd_clear = clear clear_arg options?")
     call ifile_append (ifile, "KEY clear")
     call ifile_append (ifile, "ARG clear_arg = ( clearable* )")
     call ifile_append (ifile, "ALT clearable = " &
          // "beams | iterations | " &
          // "cuts | weight | " &
          // "scale | factorization_scale | renormalization_scale | " &
    // "selection | reweight | analysis | " &
          // "unstable | polarized | " &
          // "expect | " &
          // "log_var | string_var | var_name")
     call ifile_append (ifile, "SEQ cmd_expect = expect expect_arg options?")
     call ifile_append (ifile, "KEY expect")
     call ifile_append (ifile, "ARG expect_arg = ( lexpr )")
     call ifile_append (ifile, "SEQ cmd_cuts = cuts '=' lexpr")
     call ifile_append (ifile, "SEQ cmd_scale = scale '=' expr")
     call ifile_append (ifile, "SEQ cmd_fac_scale = " &
          // "factorization_scale '=' expr")
     call ifile_append (ifile, "SEQ cmd_ren_scale = " &
          // "renormalization_scale '=' expr")
     call ifile_append (ifile, "SEQ cmd_weight = weight '=' expr")
     call ifile_append (ifile, "SEQ cmd_selection = selection '=' lexpr")
     call ifile_append (ifile, "SEQ cmd_reweight = reweight '=' expr")
     call ifile_append (ifile, "KEY cuts")
     call ifile_append (ifile, "KEY scale")
     call ifile_append (ifile, "KEY factorization_scale")
     call ifile_append (ifile, "KEY renormalization_scale")
     call ifile_append (ifile, "KEY weight")
     call ifile_append (ifile, "KEY selection")
     call ifile_append (ifile, "KEY reweight")
     call ifile_append (ifile, "SEQ cmd_process = process process_id '=' " &
          // "process_prt '=>' prt_state_list options?")
     call ifile_append (ifile, "KEY process")
     call ifile_append (ifile, "KEY '=>'")
     call ifile_append (ifile, "LIS process_prt = cexpr+")
     call ifile_append (ifile, "LIS prt_state_list = prt_state_sum+")
     call ifile_append (ifile, "SEQ prt_state_sum = " &
          // "prt_state prt_state_addition*")
     call ifile_append (ifile, "SEQ prt_state_addition = '+' prt_state")
     call ifile_append (ifile, "ALT prt_state = grouped_prt_state_list | cexpr")
     call ifile_append (ifile, "GRO grouped_prt_state_list = " &
          // "( prt_state_list )")
     call ifile_append (ifile, "SEQ cmd_compile = compile_cmd options?")
     call ifile_append (ifile, "SEQ compile_cmd = compile_clause compile_arg?")
     call ifile_append (ifile, "SEQ compile_clause = compile exec_name_spec?")
     call ifile_append (ifile, "KEY compile")
     call ifile_append (ifile, "SEQ exec_name_spec = as exec_name")
     call ifile_append (ifile, "KEY as")
     call ifile_append (ifile, "ALT exec_name = exec_id | string_literal")
     call ifile_append (ifile, "IDE exec_id")
     call ifile_append (ifile, "ARG compile_arg = ( lib_name* )")
     call ifile_append (ifile, "SEQ cmd_exec = exec exec_arg")
     call ifile_append (ifile, "KEY exec")
     call ifile_append (ifile, "ARG exec_arg = ( sexpr )")
     call ifile_append (ifile, "SEQ cmd_beams = beams '=' beam_def")
     call ifile_append (ifile, "KEY beams")
     call ifile_append (ifile, "SEQ beam_def = beam_spec strfun_seq*")
     call ifile_append (ifile, "SEQ beam_spec = beam_list")
     call ifile_append (ifile, "LIS beam_list = cexpr, cexpr?")
     call ifile_append (ifile, "SEQ cmd_beams_pol_density = " &
          // "beams_pol_density '=' beams_pol_spec")
     call ifile_append (ifile, "KEY beams_pol_density")
     call ifile_append (ifile, "LIS beams_pol_spec = smatrix, smatrix?")
     call ifile_append (ifile, "SEQ smatrix = '@' smatrix_arg")
     ! call ifile_append (ifile, "KEY '@'")     !!! Key already exists
     call ifile_append (ifile, "ARG smatrix_arg = ( sentry* )")
     call ifile_append (ifile, "SEQ sentry = expr extra_sentry*")
     call ifile_append (ifile, "SEQ extra_sentry = ':' expr")
     call ifile_append (ifile, "SEQ cmd_beams_pol_fraction = " &
          // "beams_pol_fraction '=' beams_par_spec")
     call ifile_append (ifile, "KEY beams_pol_fraction")
     call ifile_append (ifile, "SEQ cmd_beams_momentum = " &
          // "beams_momentum '=' beams_par_spec")
     call ifile_append (ifile, "KEY beams_momentum")
     call ifile_append (ifile, "SEQ cmd_beams_theta = " &
          // "beams_theta '=' beams_par_spec")
     call ifile_append (ifile, "KEY beams_theta")
     call ifile_append (ifile, "SEQ cmd_beams_phi = " &
          // "beams_phi '=' beams_par_spec")
     call ifile_append (ifile, "KEY beams_phi")
     call ifile_append (ifile, "LIS beams_par_spec = expr, expr?")
     call ifile_append (ifile, "SEQ strfun_seq = '=>' strfun_pair")
     call ifile_append (ifile, "LIS strfun_pair = strfun_def, strfun_def?")
     call ifile_append (ifile, "SEQ strfun_def = strfun_id")
     call ifile_append (ifile, "ALT strfun_id = " &
           // "none | lhapdf | lhapdf_photon | pdf_builtin | pdf_builtin_photon | " &
           // "isr | epa | ewa | circe1 | circe2 | energy_scan | " &
           // "gaussian | beam_events")
     call ifile_append (ifile, "KEY none")
     call ifile_append (ifile, "KEY lhapdf")
     call ifile_append (ifile, "KEY lhapdf_photon")
     call ifile_append (ifile, "KEY pdf_builtin")
     call ifile_append (ifile, "KEY pdf_builtin_photon")
     call ifile_append (ifile, "KEY isr")
     call ifile_append (ifile, "KEY epa")
     call ifile_append (ifile, "KEY ewa")
     call ifile_append (ifile, "KEY circe1")
     call ifile_append (ifile, "KEY circe2")
     call ifile_append (ifile, "KEY energy_scan")
     call ifile_append (ifile, "KEY gaussian")
     call ifile_append (ifile, "KEY beam_events")
     call ifile_append (ifile, "SEQ cmd_integrate = " &
          // "integrate proc_arg options?")
     call ifile_append (ifile, "KEY integrate")
     call ifile_append (ifile, "ARG proc_arg = ( proc_id* )")
     call ifile_append (ifile, "IDE proc_id")
     call ifile_append (ifile, "SEQ cmd_iterations = " &
          // "iterations '=' iterations_list")
     call ifile_append (ifile, "KEY iterations")
     call ifile_append (ifile, "LIS iterations_list = iterations_spec+")
     call ifile_append (ifile, "ALT iterations_spec = it_spec")
     call ifile_append (ifile, "SEQ it_spec = expr calls_spec adapt_spec?")
     call ifile_append (ifile, "SEQ calls_spec = ':' expr")
     call ifile_append (ifile, "SEQ adapt_spec = ':' sexpr")
     call ifile_append (ifile, "SEQ cmd_components = " &
          // "active '=' component_list")
     call ifile_append (ifile, "KEY active")
     call ifile_append (ifile, "LIS component_list = sexpr+")
     call ifile_append (ifile, "SEQ cmd_sample_format = " &
          // "sample_format '=' event_format_list")
     call ifile_append (ifile, "KEY sample_format")
     call ifile_append (ifile, "LIS event_format_list = event_format+")
     call ifile_append (ifile, "IDE event_format")
     call ifile_append (ifile, "SEQ cmd_observable = " &
          // "observable analysis_tag options?")
     call ifile_append (ifile, "KEY observable")
     call ifile_append (ifile, "SEQ cmd_histogram = " &
          // "histogram analysis_tag histogram_arg " &
          // "options?")
     call ifile_append (ifile, "KEY histogram")
     call ifile_append (ifile, "ARG histogram_arg = (expr, expr, expr?)")
     call ifile_append (ifile, "SEQ cmd_plot = plot analysis_tag options?")
     call ifile_append (ifile, "KEY plot")
     call ifile_append (ifile, "SEQ cmd_graph = graph graph_term '=' graph_def")
     call ifile_append (ifile, "KEY graph")
     call ifile_append (ifile, "SEQ graph_term = analysis_tag options?")
     call ifile_append (ifile, "SEQ graph_def = graph_term graph_append*")
     call ifile_append (ifile, "SEQ graph_append = '&' graph_term")
     call ifile_append (ifile, "SEQ cmd_analysis = analysis '=' lexpr")
     call ifile_append (ifile, "KEY analysis")
     call ifile_append (ifile, "SEQ cmd_alt_setup = " &
          // "alt_setup '=' option_list_expr")
     call ifile_append (ifile, "KEY alt_setup")
     call ifile_append (ifile, "ALT option_list_expr = " &
          // "grouped_option_list | option_list")
     call ifile_append (ifile, "GRO grouped_option_list = ( option_list_expr )")
     call ifile_append (ifile, "LIS option_list = options+")
     call ifile_append (ifile, "SEQ cmd_open_out = open_out open_arg options?")
     call ifile_append (ifile, "SEQ cmd_close_out = close_out open_arg options?")
     call ifile_append (ifile, "KEY open_out")
     call ifile_append (ifile, "KEY close_out")
     call ifile_append (ifile, "ARG open_arg = (sexpr)")
     call ifile_append (ifile, "SEQ cmd_printf = printf_cmd options?")
     call ifile_append (ifile, "SEQ printf_cmd = printf_clause sprintf_args?")
     call ifile_append (ifile, "SEQ printf_clause = printf sexpr")
     call ifile_append (ifile, "KEY printf")
     call ifile_append (ifile, "SEQ cmd_record = record_cmd")
     call ifile_append (ifile, "SEQ cmd_unstable = " &
          // "unstable cexpr unstable_arg options?")
     call ifile_append (ifile, "KEY unstable")
     call ifile_append (ifile, "ARG unstable_arg = ( proc_id* )")
     call ifile_append (ifile, "SEQ cmd_stable = stable stable_list options?")
     call ifile_append (ifile, "KEY stable")
     call ifile_append (ifile, "LIS stable_list = cexpr+")
     call ifile_append (ifile, "KEY polarized")
     call ifile_append (ifile, "SEQ cmd_polarized = polarized polarized_list options?")
     call ifile_append (ifile, "LIS polarized_list = cexpr+")
     call ifile_append (ifile, "KEY unpolarized")
     call ifile_append (ifile, "SEQ cmd_unpolarized = unpolarized unpolarized_list options?")
     call ifile_append (ifile, "LIS unpolarized_list = cexpr+")
     call ifile_append (ifile, "SEQ cmd_simulate = " &
          // "simulate proc_arg options?")
     call ifile_append (ifile, "KEY simulate")
     call ifile_append (ifile, "SEQ cmd_rescan = " &
          // "rescan sexpr proc_arg options?")
     call ifile_append (ifile, "KEY rescan")
     call ifile_append (ifile, "SEQ cmd_scan = scan scan_var scan_body?")
     call ifile_append (ifile, "KEY scan")
     call ifile_append (ifile, "ALT scan_var = " &
          // "scan_log_decl | scan_log | " &
          // "scan_int | scan_real | scan_complex | scan_num | " &
          // "scan_string_decl | scan_string | scan_alias | " &
          // "scan_cuts | scan_weight | " &
          // "scan_scale | scan_ren_scale | scan_fac_scale | " &
          // "scan_selection | scan_reweight | scan_analysis | " &
          // "scan_model | scan_library")
     call ifile_append (ifile, "SEQ scan_log_decl = logical scan_log")
     call ifile_append (ifile, "SEQ scan_log = '?' var_name '=' scan_log_arg")
     call ifile_append (ifile, "ARG scan_log_arg = ( lexpr* )")
     call ifile_append (ifile, "SEQ scan_int = int var_name '=' scan_num_arg")
     call ifile_append (ifile, "SEQ scan_real = real var_name '=' scan_num_arg")
     call ifile_append (ifile, "SEQ scan_complex = " &
          // "complex var_name '=' scan_num_arg")
     call ifile_append (ifile, "SEQ scan_num = var_name '=' scan_num_arg")
     call ifile_append (ifile, "ARG scan_num_arg = ( range* )")
     call ifile_append (ifile, "ALT range = grouped_range | range_expr")
     call ifile_append (ifile, "GRO grouped_range = ( range_expr )")
     call ifile_append (ifile, "SEQ range_expr = expr range_spec?")
     call ifile_append (ifile, "SEQ range_spec = '=>' expr step_spec?")
     call ifile_append (ifile, "SEQ step_spec = step_op expr")
     call ifile_append (ifile, "ALT step_op = " &
          // "'/+' | '/-' | '/*' | '//' | '/+/' | '/*/'")
     call ifile_append (ifile, "KEY '/+'")
     call ifile_append (ifile, "KEY '/-'")
     call ifile_append (ifile, "KEY '/*'")
     call ifile_append (ifile, "KEY '//'")
     call ifile_append (ifile, "KEY '/+/'")
     call ifile_append (ifile, "KEY '/*/'")
     call ifile_append (ifile, "SEQ scan_string_decl = string scan_string")
     call ifile_append (ifile, "SEQ scan_string = " &
          // "'$' var_name '=' scan_string_arg")
     call ifile_append (ifile, "ARG scan_string_arg = ( sexpr* )")
     call ifile_append (ifile, "SEQ scan_alias = " &
          // "alias var_name '=' scan_alias_arg")
     call ifile_append (ifile, "ARG scan_alias_arg = ( cexpr* )")
     call ifile_append (ifile, "SEQ scan_cuts = cuts '=' scan_lexpr_arg")
     call ifile_append (ifile, "ARG scan_lexpr_arg = ( lexpr* )")
     call ifile_append (ifile, "SEQ scan_scale = scale '=' scan_expr_arg")
     call ifile_append (ifile, "ARG scan_expr_arg = ( expr* )")
     call ifile_append (ifile, "SEQ scan_fac_scale = " &
          // "factorization_scale '=' scan_expr_arg")
     call ifile_append (ifile, "SEQ scan_ren_scale = " &
          // "renormalization_scale '=' scan_expr_arg")
     call ifile_append (ifile, "SEQ scan_weight = weight '=' scan_expr_arg")
     call ifile_append (ifile, "SEQ scan_selection = selection '=' scan_lexpr_arg")
     call ifile_append (ifile, "SEQ scan_reweight = reweight '=' scan_expr_arg")
     call ifile_append (ifile, "SEQ scan_analysis = analysis '=' scan_lexpr_arg")
     call ifile_append (ifile, "SEQ scan_model = model '=' scan_model_arg")
     call ifile_append (ifile, "ARG scan_model_arg = ( model_name* )")
     call ifile_append (ifile, "SEQ scan_library = library '=' scan_library_arg")
     call ifile_append (ifile, "ARG scan_library_arg = ( lib_name* )")
     call ifile_append (ifile, "GRO scan_body = '{' command_list '}'")
     call ifile_append (ifile, "SEQ cmd_if = " &
          // "if lexpr then command_list elsif_clauses else_clause endif")
     call ifile_append (ifile, "SEQ elsif_clauses = cmd_elsif*")
     call ifile_append (ifile, "SEQ cmd_elsif = elsif lexpr then command_list")
     call ifile_append (ifile, "SEQ else_clause = cmd_else?")
     call ifile_append (ifile, "SEQ cmd_else = else command_list")
     call ifile_append (ifile, "SEQ cmd_include = include include_arg")
     call ifile_append (ifile, "KEY include")
     call ifile_append (ifile, "ARG include_arg = ( string_literal )")
     call ifile_append (ifile, "SEQ cmd_quit = quit_cmd quit_arg?")
     call ifile_append (ifile, "ALT quit_cmd = quit | exit")
     call ifile_append (ifile, "KEY quit")
     call ifile_append (ifile, "KEY exit")
     call ifile_append (ifile, "ARG quit_arg = ( expr )")
     call ifile_append (ifile, "SEQ cmd_export = export show_arg options?")
     call ifile_append (ifile, "KEY export")
     call ifile_append (ifile, "SEQ cmd_write_analysis = " &
          // "write_analysis_clause options?")
     call ifile_append (ifile, "SEQ cmd_compile_analysis = " &
          // "compile_analysis_clause options?")
     call ifile_append (ifile, "SEQ write_analysis_clause = " &
          // "write_analysis write_analysis_arg?")
     call ifile_append (ifile, "SEQ compile_analysis_clause = " &
          // "compile_analysis write_analysis_arg?")
     call ifile_append (ifile, "KEY write_analysis")
     call ifile_append (ifile, "KEY compile_analysis")
     call ifile_append (ifile, "ARG write_analysis_arg = ( analysis_tag* )")
     call ifile_append (ifile, "SEQ cmd_nlo = " &
                        // "nlo_calculation '=' nlo_calculation_list")
     call ifile_append (ifile, "KEY nlo_calculation")
     call ifile_append (ifile, "LIS nlo_calculation_list = nlo_comp+")
     call ifile_append (ifile, "ALT nlo_comp = " // &
          "full | born | real | virtual | dglap | subtraction | " // &
          "mismatch | GKS")
     call ifile_append (ifile, "KEY full")
     call ifile_append (ifile, "KEY born")
     call ifile_append (ifile, "KEY virtual")
     call ifile_append (ifile, "KEY dglap")
     call ifile_append (ifile, "KEY subtraction")
     call ifile_append (ifile, "KEY mismatch")
     call ifile_append (ifile, "KEY GKS")
     call define_expr_syntax (ifile, particles=.true., analysis=.true.)
   end subroutine define_cmd_list_syntax
 
 @ %def define_cmd_list_syntax
 <<Commands: public>>=
   public :: lexer_init_cmd_list
 <<Commands: procedures>>=
   subroutine lexer_init_cmd_list (lexer, parent_lexer)
     type(lexer_t), intent(out) :: lexer
     type(lexer_t), intent(in), optional, target :: parent_lexer
     call lexer_init (lexer, &
          comment_chars = "#!", &
          quote_chars = '"', &
          quote_match = '"', &
          single_chars = "()[]{},;:&%?$@", &
          special_class = [ "+-*/^", "<>=~ " ] , &
          keyword_list = syntax_get_keyword_list_ptr (syntax_cmd_list), &
          parent = parent_lexer)
   end subroutine lexer_init_cmd_list
 
 @ %def lexer_init_cmd_list
 @
 \subsection{Unit Tests}
 Test module, followed by the corresponding implementation module.
 <<[[commands_ut.f90]]>>=
 <<File header>>
 
 module commands_ut
   use unit_tests
   use commands_uti
 
 <<Standard module head>>
 
 <<Commands: public test>>
 
 contains
 
 <<Commands: test driver>>
 
 end module commands_ut
 @ %def commands_ut
 @
 <<[[commands_uti.f90]]>>=
 <<File header>>
 
 module commands_uti
 
   <<Use kinds>>
     use kinds, only: i64
   <<Use strings>>
     use io_units
     use ifiles
     use parser
     use interactions, only: reset_interaction_counter
     use prclib_stacks
     use analysis
     use variables, only: var_list_t
     use models
     use slha_interface
     use rt_data
     use event_base, only: generic_event_t, event_callback_t
 
     use commands
 
 <<Standard module head>>
 
 <<Commands: test declarations>>
 
 <<Commands: test auxiliary types>>
 
 contains
 
 <<Commands: tests>>
 
 <<Commands: test auxiliary>>
 
 end module commands_uti
 
 @ %def commands_uti
 @ API: driver for the unit tests below.
 <<Commands: public test>>=
   public :: commands_test
 <<Commands: test driver>>=
   subroutine commands_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Commands: execute tests>>
   end subroutine commands_test
 
 @ %def commands_test
 @
 \subsubsection{Prepare Sindarin code}
 This routine parses an internal file, prints the parse tree, and
 returns a parse node to the root.  We use the routine in the tests
 below.
 <<Commands: public test auxiliary>>=
   public :: parse_ifile
 <<Commands: test auxiliary>>=
   subroutine parse_ifile (ifile, pn_root, u)
     use ifiles
     use lexers
     use parser
     use commands
     type(ifile_t), intent(in) :: ifile
     type(parse_node_t), pointer, intent(out) :: pn_root
     integer, intent(in), optional :: u
     type(stream_t), target :: stream
     type(lexer_t), target :: lexer
     type(parse_tree_t) :: parse_tree
 
     call lexer_init_cmd_list (lexer)
     call stream_init (stream, ifile)
     call lexer_assign_stream (lexer, stream)
 
     call parse_tree_init (parse_tree, syntax_cmd_list, lexer)
     if (present (u))  call parse_tree_write (parse_tree, u)
     pn_root => parse_tree%get_root_ptr ()
 
     call stream_final (stream)
     call lexer_final (lexer)
   end subroutine parse_ifile
 
 @ %def parse_ifile
 @
 \subsubsection{Empty command list}
 Compile and execute an empty command list.  Should do nothing but
 test the integrity of the workflow.
 <<Commands: execute tests>>=
   call test (commands_1, "commands_1", &
        "empty command list", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_1
 <<Commands: tests>>=
   subroutine commands_1 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_1"
     write (u, "(A)")  "*   Purpose: compile and execute empty command list"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Parse empty file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
 
     if (associated (pn_root)) then
        call command_list%compile (pn_root, global)
     end if
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
 
     call global%activate ()
     call command_list%execute (global)
     call global%deactivate ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call syntax_cmd_list_final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_1"
 
   end subroutine commands_1
 
 @ %def commands_1
 @
 \subsubsection{Read model}
 Execute a [[model]] assignment.
 <<Commands: execute tests>>=
   call test (commands_2, "commands_2", &
        "model", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_2
 <<Commands: tests>>=
   subroutine commands_2 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_2"
     write (u, "(A)")  "*   Purpose: set model"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_2"
 
   end subroutine commands_2
 
 @ %def commands_2
 @
 \subsubsection{Declare Process}
 Read a model, then declare a process.  The process library is allocated
 explicitly.  For the process definition, We take the default ([[omega]])
 method.  Since we do not compile, \oMega\ is not actually called.
 <<Commands: execute tests>>=
   call test (commands_3, "commands_3", &
        "process declaration", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_3
 <<Commands: tests>>=
   subroutine commands_3 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: commands_3"
     write (u, "(A)")  "*   Purpose: define process"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
     call global%var_list%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd3"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process t3 = s, s => s, s')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%prclib_stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_3"
 
   end subroutine commands_3
 
 @ %def commands_3
 @
 \subsubsection{Compile Process}
 Read a model, then declare a process and compile the library.  The process
 library is allocated explicitly.  For the process definition, We take the
 default ([[unit_test]]) method.  There is no external code, so compilation of
 the library is merely a formal status change.
 <<Commands: execute tests>>=
   call test (commands_4, "commands_4", &
        "compilation", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_4
 <<Commands: tests>>=
   subroutine commands_4 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: commands_4"
     write (u, "(A)")  "*   Purpose: define process and compile library"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd4"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process t4 = s, s => s, s')
     call ifile_append (ifile, 'compile ("lib_cmd4")')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%prclib_stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_4"
 
   end subroutine commands_4
 
 @ %def commands_4
 @
 \subsubsection{Integrate Process}
 Read a model, then declare a process, compile the library, and
 integrate over phase space.  We take the
 default ([[unit_test]]) method and use the simplest methods of
 phase-space parameterization and integration.
 <<Commands: execute tests>>=
   call test (commands_5, "commands_5", &
        "integration", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_5
 <<Commands: tests>>=
   subroutine commands_5 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: commands_5"
     write (u, "(A)")  "*   Purpose: define process, iterations, and integrate"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
     call global%var_list%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known=.true.)
     call global%var_list%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known=.true.)
     call global%var_list%set_log (var_str ("?vis_history"),&
          .false., is_known=.true.)
     call global%var_list%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%var_list%set_real (var_str ("sqrts"), &
          1000._default, is_known=.true.)
     call global%var_list%set_int (var_str ("seed"), 0, is_known=.true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd5"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process t5 = s, s => s, s')
     call ifile_append (ifile, 'compile')
     call ifile_append (ifile, 'iterations = 1:1000')
     call ifile_append (ifile, 'integrate (t5)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call command_list%execute (global)
 
     call global%it_list%write (u)
     write (u, "(A)")
     call global%process_stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_5"
 
   end subroutine commands_5
 
 @ %def commands_5
 @
 \subsubsection{Variables}
 Set intrinsic and user-defined variables.
 <<Commands: execute tests>>=
   call test (commands_6, "commands_6", &
        "variables", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_6
 <<Commands: tests>>=
   subroutine commands_6 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_6"
     write (u, "(A)")  "*   Purpose: define and set variables"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
     call global%write_vars (u, [ &
          var_str ("$run_id"), &
          var_str ("?unweighted"), &
          var_str ("sqrts")])
 
     write (u, "(A)")
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, '$run_id = "run1"')
     call ifile_append (ifile, '?unweighted = false')
     call ifile_append (ifile, 'sqrts = 1000')
     call ifile_append (ifile, 'int j = 10')
     call ifile_append (ifile, 'real x = 1000.')
     call ifile_append (ifile, 'complex z = 5')
     call ifile_append (ifile, 'string $text = "abcd"')
     call ifile_append (ifile, 'logical ?flag = true')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write_vars (u, [ &
          var_str ("$run_id"), &
          var_str ("?unweighted"), &
          var_str ("sqrts"), &
          var_str ("j"), &
          var_str ("x"), &
          var_str ("z"), &
          var_str ("$text"), &
          var_str ("?flag")])
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call syntax_cmd_list_final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_6"
 
   end subroutine commands_6
 
 @ %def commands_6
 @
 \subsubsection{Process library}
 Open process libraries explicitly.
 <<Commands: execute tests>>=
   call test (commands_7, "commands_7", &
        "process library", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_7
 <<Commands: tests>>=
   subroutine commands_7 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_7"
     write (u, "(A)")  "*   Purpose: declare process libraries"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
     call global%var_list%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
     global%os_data%fc = "Fortran-compiler"
     global%os_data%fcflags = "Fortran-flags"
 
     write (u, "(A)")
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'library = "lib_cmd7_1"')
     call ifile_append (ifile, 'library = "lib_cmd7_2"')
     call ifile_append (ifile, 'library = "lib_cmd7_1"')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write_libraries (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call syntax_cmd_list_final ()
     call global%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_7"
 
   end subroutine commands_7
 
 @ %def commands_7
 @
 \subsubsection{Generate events}
 Read a model, then declare a process, compile the library, and
 generate weighted events.  We take the
 default ([[unit_test]]) method and use the simplest methods of
 phase-space parameterization and integration.
 <<Commands: execute tests>>=
   call test (commands_8, "commands_8", &
        "event generation", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_8
 <<Commands: tests>>=
   subroutine commands_8 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: commands_8"
     write (u, "(A)")  "*   Purpose: define process, integrate, generate events"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
     call global%var_list%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known=.true.)
     call global%var_list%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known=.true.)
     call global%var_list%set_log (var_str ("?vis_history"),&
          .false., is_known=.true.)
     call global%var_list%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%var_list%set_real (var_str ("sqrts"), &
          1000._default, is_known=.true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd8"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process commands_8_p = s, s => s, s')
     call ifile_append (ifile, 'compile')
     call ifile_append (ifile, 'iterations = 1:1000')
     call ifile_append (ifile, 'integrate (commands_8_p)')
     call ifile_append (ifile, '?unweighted = false')
     call ifile_append (ifile, 'n_events = 3')
     call ifile_append (ifile, '?read_raw = false')
     call ifile_append (ifile, 'simulate (commands_8_p)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
 
     call command_list%execute (global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_8"
 
   end subroutine commands_8
 
 @ %def commands_8
 @
 \subsubsection{Define cuts}
 Declare a cut expression.
 <<Commands: execute tests>>=
   call test (commands_9, "commands_9", &
        "cuts", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_9
 <<Commands: tests>>=
   subroutine commands_9 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(string_t), dimension(0) :: no_vars
 
     write (u, "(A)")  "* Test output: commands_9"
     write (u, "(A)")  "*   Purpose: define cuts"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'cuts = all Pt > 0 [particle]')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write (u, vars = no_vars)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_9"
 
   end subroutine commands_9
 
 @ %def commands_9
 @
 \subsubsection{Beams}
 Define beam setup.
 <<Commands: execute tests>>=
   call test (commands_10, "commands_10", &
        "beams", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_10
 <<Commands: tests>>=
   subroutine commands_10 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_10"
     write (u, "(A)")  "*   Purpose: define beams"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = QCD')
     call ifile_append (ifile, 'sqrts = 1000')
     call ifile_append (ifile, 'beams = p, p')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write_beams (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_10"
 
   end subroutine commands_10
 
 @ %def commands_10
 @
 \subsubsection{Structure functions}
 Define beam setup with structure functions
 <<Commands: execute tests>>=
   call test (commands_11, "commands_11", &
        "structure functions", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_11
 <<Commands: tests>>=
   subroutine commands_11 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_11"
     write (u, "(A)")  "*   Purpose: define beams with structure functions"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = QCD')
     call ifile_append (ifile, 'sqrts = 1100')
     call ifile_append (ifile, 'beams = p, p => lhapdf => pdf_builtin, isr')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write_beams (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_11"
 
   end subroutine commands_11
 
 @ %def commands_11
 @
 \subsubsection{Rescan events}
 Read a model, then declare a process, compile the library, and
 generate weighted events.  We take the
 default ([[unit_test]]) method and use the simplest methods of
 phase-space parameterization and integration.  Then, rescan the
 generated event sample.
 <<Commands: execute tests>>=
   call test (commands_12, "commands_12", &
        "event rescanning", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_12
 <<Commands: tests>>=
   subroutine commands_12 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: commands_12"
     write (u, "(A)")  "*   Purpose: generate events and rescan"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
 
     call global%global_init ()
     call global%var_list%append_log (&
          var_str ("?rebuild_phase_space"), .false., &
          intrinsic=.true.)
     call global%var_list%append_log (&
          var_str ("?rebuild_grids"), .false., &
          intrinsic=.true.)
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
     call global%var_list%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known=.true.)
     call global%var_list%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known=.true.)
     call global%var_list%set_log (var_str ("?vis_history"),&
          .false., is_known=.true.)
     call global%var_list%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%var_list%set_real (var_str ("sqrts"), &
          1000._default, is_known=.true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd12"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process commands_12_p = s, s => s, s')
     call ifile_append (ifile, 'compile')
     call ifile_append (ifile, 'iterations = 1:1000')
     call ifile_append (ifile, 'integrate (commands_12_p)')
     call ifile_append (ifile, '?unweighted = false')
     call ifile_append (ifile, 'n_events = 3')
     call ifile_append (ifile, '?read_raw = false')
     call ifile_append (ifile, 'simulate (commands_12_p)')
     call ifile_append (ifile, '?write_raw = false')
     call ifile_append (ifile, 'rescan "commands_12_p" (commands_12_p)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
 
     call command_list%execute (global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_12"
 
   end subroutine commands_12
 
 @ %def commands_12
 @
 \subsubsection{Event Files}
 Set output formats for event files.
 <<Commands: execute tests>>=
   call test (commands_13, "commands_13", &
        "event output formats", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_13
 <<Commands: tests>>=
   subroutine commands_13 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
     logical :: exist
 
     write (u, "(A)")  "* Test output: commands_13"
     write (u, "(A)")  "*   Purpose: generate events and rescan"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
     call global%var_list%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known=.true.)
     call global%var_list%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known=.true.)
     call global%var_list%set_real (var_str ("sqrts"), &
          1000._default, is_known=.true.)
     call global%var_list%set_log (var_str ("?vis_history"),&
          .false., is_known=.true.)
     call global%var_list%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd13"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process commands_13_p = s, s => s, s')
     call ifile_append (ifile, 'compile')
     call ifile_append (ifile, 'iterations = 1:1000')
     call ifile_append (ifile, 'integrate (commands_13_p)')
     call ifile_append (ifile, '?unweighted = false')
     call ifile_append (ifile, 'n_events = 1')
     call ifile_append (ifile, '?read_raw = false')
     call ifile_append (ifile, 'sample_format = weight_stream')
     call ifile_append (ifile, 'simulate (commands_13_p)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
 
     call command_list%execute (global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Verify output files"
     write (u, "(A)")
 
     inquire (file = "commands_13_p.evx", exist = exist)
     if (exist)  write (u, "(1x,A)")  "raw"
 
     inquire (file = "commands_13_p.weights.dat", exist = exist)
     if (exist)  write (u, "(1x,A)")  "weight_stream"
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_13"
 
   end subroutine commands_13
 
 @ %def commands_13
 @
 \subsubsection{Compile Empty Libraries}
 (This is a regression test:)  Declare two empty libraries and compile them.
 <<Commands: execute tests>>=
   call test (commands_14, "commands_14", &
        "empty libraries", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_14
 <<Commands: tests>>=
   subroutine commands_14 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_14"
     write (u, "(A)")  "*   Purpose: define and compile empty libraries"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_cmd_list_init ()
 
     call global%global_init ()
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'library = "lib1"')
     call ifile_append (ifile, 'library = "lib2"')
     call ifile_append (ifile, 'compile ()')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%prclib_stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
 
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_14"
 
   end subroutine commands_14
 
 @ %def commands_14
 @
 \subsubsection{Compile Process}
 Read a model, then declare a process and compile the library.  The process
 library is allocated explicitly.  For the process definition, We take the
 default ([[unit_test]]) method.  There is no external code, so compilation of
 the library is merely a formal status change.
 <<Commands: execute tests>>=
   call test (commands_15, "commands_15", &
        "compilation", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_15
 <<Commands: tests>>=
   subroutine commands_15 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: commands_15"
     write (u, "(A)")  "*   Purpose: define process and compile library"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
     call global%var_list%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known=.true.)
     call global%var_list%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known=.true.)
     call global%var_list%set_real (var_str ("sqrts"), &
          1000._default, is_known=.true.)
     call global%var_list%set_log (var_str ("?vis_history"),&
          .false., is_known=.true.)
     call global%var_list%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd15"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process t15 = s, s => s, s')
     call ifile_append (ifile, 'iterations = 1:1000')
     call ifile_append (ifile, 'integrate (t15)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%prclib_stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_15"
 
   end subroutine commands_15
 
 @ %def commands_15
 @
 \subsubsection{Observable}
 Declare an observable, fill it and display.
 <<Commands: execute tests>>=
   call test (commands_16, "commands_16", &
        "observables", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_16
 <<Commands: tests>>=
   subroutine commands_16 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_16"
     write (u, "(A)")  "*   Purpose: declare an observable"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, '$obs_label = "foo"')
     call ifile_append (ifile, '$obs_unit = "cm"')
     call ifile_append (ifile, '$title = "Observable foo"')
     call ifile_append (ifile, '$description = "This is observable foo"')
     call ifile_append (ifile, 'observable foo')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Record two data items"
     write (u, "(A)")
 
     call analysis_record_data (var_str ("foo"), 1._default)
     call analysis_record_data (var_str ("foo"), 3._default)
 
     write (u, "(A)")  "* Display analysis store"
     write (u, "(A)")
 
     call analysis_write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_16"
 
   end subroutine commands_16
 
 @ %def commands_16
 @
 \subsubsection{Histogram}
 Declare a histogram, fill it and display.
 <<Commands: execute tests>>=
   call test (commands_17, "commands_17", &
        "histograms", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_17
 <<Commands: tests>>=
   subroutine commands_17 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(string_t), dimension(3) :: name
     integer :: i
 
     write (u, "(A)")  "* Test output: commands_17"
     write (u, "(A)")  "*   Purpose: declare histograms"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, '$obs_label = "foo"')
     call ifile_append (ifile, '$obs_unit = "cm"')
     call ifile_append (ifile, '$title = "Histogram foo"')
     call ifile_append (ifile, '$description = "This is histogram foo"')
     call ifile_append (ifile, 'histogram foo (0,5,1)')
     call ifile_append (ifile, '$title = "Histogram bar"')
     call ifile_append (ifile, '$description = "This is histogram bar"')
     call ifile_append (ifile, 'n_bins = 2')
     call ifile_append (ifile, 'histogram bar (0,5)')
     call ifile_append (ifile, '$title = "Histogram gee"')
     call ifile_append (ifile, '$description = "This is histogram gee"')
     call ifile_append (ifile, '?normalize_bins = true')
     call ifile_append (ifile, 'histogram gee (0,5)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Record two data items"
     write (u, "(A)")
 
     name(1) = "foo"
     name(2) = "bar"
     name(3) = "gee"
 
     do i = 1, 3
        call analysis_record_data (name(i), 0.1_default, &
             weight = 0.25_default)
        call analysis_record_data (name(i), 3.1_default)
        call analysis_record_data (name(i), 4.1_default, &
             excess = 0.5_default)
        call analysis_record_data (name(i), 7.1_default)
     end do
 
     write (u, "(A)")  "* Display analysis store"
     write (u, "(A)")
 
     call analysis_write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_17"
 
   end subroutine commands_17
 
 @ %def commands_17
 @
 \subsubsection{Plot}
 Declare a plot, fill it and display contents.
 <<Commands: execute tests>>=
   call test (commands_18, "commands_18", &
        "plots", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_18
 <<Commands: tests>>=
   subroutine commands_18 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_18"
     write (u, "(A)")  "*   Purpose: declare a plot"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, '$obs_label = "foo"')
     call ifile_append (ifile, '$obs_unit = "cm"')
     call ifile_append (ifile, '$title = "Plot foo"')
     call ifile_append (ifile, '$description = "This is plot foo"')
     call ifile_append (ifile, '$x_label = "x axis"')
     call ifile_append (ifile, '$y_label = "y axis"')
     call ifile_append (ifile, '?x_log = false')
     call ifile_append (ifile, '?y_log = true')
     call ifile_append (ifile, 'x_min = -1')
     call ifile_append (ifile, 'x_max = 1')
     call ifile_append (ifile, 'y_min = 0.1')
     call ifile_append (ifile, 'y_max = 1000')
     call ifile_append (ifile, 'plot foo')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Record two data items"
     write (u, "(A)")
 
     call analysis_record_data (var_str ("foo"), 0._default, 20._default, &
          xerr = 0.25_default)
     call analysis_record_data (var_str ("foo"), 0.5_default, 0.2_default, &
          yerr = 0.07_default)
     call analysis_record_data (var_str ("foo"), 3._default, 2._default)
 
     write (u, "(A)")  "* Display analysis store"
     write (u, "(A)")
 
     call analysis_write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_18"
 
   end subroutine commands_18
 
 @ %def commands_18
 @
 \subsubsection{Graph}
 Combine two (empty) plots to a graph.
 <<Commands: execute tests>>=
   call test (commands_19, "commands_19", &
        "graphs", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_19
 <<Commands: tests>>=
   subroutine commands_19 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_19"
     write (u, "(A)")  "*   Purpose: combine two plots to a graph"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'plot a')
     call ifile_append (ifile, 'plot b')
     call ifile_append (ifile, '$title = "Graph foo"')
     call ifile_append (ifile, '$description = "This is graph foo"')
     call ifile_append (ifile, 'graph foo = a & b')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Display analysis object"
     write (u, "(A)")
 
     call analysis_write (var_str ("foo"), u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_19"
 
   end subroutine commands_19
 
 @ %def commands_19
 @
 \subsubsection{Record Data}
 Record data in previously allocated analysis objects.
 <<Commands: execute tests>>=
   call test (commands_20, "commands_20", &
        "record data", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_20
 <<Commands: tests>>=
   subroutine commands_20 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_20"
     write (u, "(A)")  "*   Purpose: record data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization: create observable, histogram, plot"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     call analysis_init_observable (var_str ("o"))
     call analysis_init_histogram (var_str ("h"), 0._default, 1._default, 3, &
          normalize_bins = .false.)
     call analysis_init_plot (var_str ("p"))
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'record o (1.234)')
     call ifile_append (ifile, 'record h (0.5)')
     call ifile_append (ifile, 'record p (1, 2)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Display analysis object"
     write (u, "(A)")
 
     call analysis_write (u, verbose = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_20"
 
   end subroutine commands_20
 
 @ %def commands_20
 @
 \subsubsection{Analysis}
 Declare an analysis expression and use it to fill an observable during
 event generation.
 <<Commands: execute tests>>=
   call test (commands_21, "commands_21", &
        "analysis expression", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_21
 <<Commands: tests>>=
   subroutine commands_21 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: commands_21"
     write (u, "(A)")  "*   Purpose: create and use analysis expression"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization: create observable"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
     call global%var_list%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known=.true.)
     call global%var_list%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known=.true.)
     call global%var_list%set_log (var_str ("?vis_history"),&
          .false., is_known=.true.)
     call global%var_list%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
     call global%var_list%set_real (var_str ("sqrts"), &
          1000._default, is_known=.true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd8"))
     call global%add_prclib (lib)
 
     call analysis_init_observable (var_str ("m"))
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process commands_21_p = s, s => s, s')
     call ifile_append (ifile, 'compile')
     call ifile_append (ifile, 'iterations = 1:100')
     call ifile_append (ifile, 'integrate (commands_21_p)')
     call ifile_append (ifile, '?unweighted = true')
     call ifile_append (ifile, 'n_events = 3')
     call ifile_append (ifile, '?read_raw = false')
     call ifile_append (ifile, 'observable m')
     call ifile_append (ifile, 'analysis = record m (eval M [s])')
     call ifile_append (ifile, 'simulate (commands_21_p)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Display analysis object"
     write (u, "(A)")
 
     call analysis_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_21"
 
   end subroutine commands_21
 
 @ %def commands_21
 @
 \subsubsection{Write Analysis}
 Write accumulated analysis data to file.
 <<Commands: execute tests>>=
   call test (commands_22, "commands_22", &
        "write analysis", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_22
 <<Commands: tests>>=
   subroutine commands_22 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     integer :: u_file, iostat
     logical :: exist
     character(80) :: buffer
 
     write (u, "(A)")  "* Test output: commands_22"
     write (u, "(A)")  "*   Purpose: write analysis data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization: create observable"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     call analysis_init_observable (var_str ("m"))
     call analysis_record_data (var_str ("m"), 125._default)
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, '$out_file = "commands_22.dat"')
     call ifile_append (ifile, 'write_analysis')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Display analysis data"
     write (u, "(A)")
 
     inquire (file = "commands_22.dat", exist = exist)
     if (.not. exist) then
        write (u, "(A)")  "ERROR: File commands_22.dat not found"
        return
     end if
 
     u_file = free_unit ()
     open (u_file, file = "commands_22.dat", &
          action = "read", status = "old")
     do
        read (u_file, "(A)", iostat = iostat)  buffer
        if (iostat /= 0)  exit
        write (u, "(A)") trim (buffer)
     end do
     close (u_file)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_22"
 
   end subroutine commands_22
 
 @ %def commands_22
 @
 \subsubsection{Compile Analysis}
 Write accumulated analysis data to file and compile.
 <<Commands: execute tests>>=
   call test (commands_23, "commands_23", &
        "compile analysis", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_23
 <<Commands: tests>>=
   subroutine commands_23 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     integer :: u_file, iostat
     character(256) :: buffer
     logical :: exist
     type(graph_options_t) :: graph_options
 
     write (u, "(A)")  "* Test output: commands_23"
     write (u, "(A)")  "*   Purpose: write and compile analysis data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization: create and fill histogram"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     call graph_options_init (graph_options)
     call graph_options_set (graph_options, &
          title = var_str ("Histogram for test: commands 23"), &
          description = var_str ("This is a test."), &
          width_mm = 125, height_mm = 85)
     call analysis_init_histogram (var_str ("h"), &
          0._default, 10._default, 2._default, .false., &
          graph_options = graph_options)
     call analysis_record_data (var_str ("h"), 1._default)
     call analysis_record_data (var_str ("h"), 1._default)
     call analysis_record_data (var_str ("h"), 1._default)
     call analysis_record_data (var_str ("h"), 1._default)
     call analysis_record_data (var_str ("h"), 3._default)
     call analysis_record_data (var_str ("h"), 3._default)
     call analysis_record_data (var_str ("h"), 3._default)
     call analysis_record_data (var_str ("h"), 5._default)
     call analysis_record_data (var_str ("h"), 7._default)
     call analysis_record_data (var_str ("h"), 7._default)
     call analysis_record_data (var_str ("h"), 7._default)
     call analysis_record_data (var_str ("h"), 7._default)
     call analysis_record_data (var_str ("h"), 9._default)
     call analysis_record_data (var_str ("h"), 9._default)
     call analysis_record_data (var_str ("h"), 9._default)
     call analysis_record_data (var_str ("h"), 9._default)
     call analysis_record_data (var_str ("h"), 9._default)
     call analysis_record_data (var_str ("h"), 9._default)
     call analysis_record_data (var_str ("h"), 9._default)
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, '$out_file = "commands_23.dat"')
     call ifile_append (ifile, 'compile_analysis')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Delete Postscript output"
     write (u, "(A)")
 
     inquire (file = "commands_23.ps", exist = exist)
     if (exist) then
        u_file = free_unit ()
        open (u_file, file = "commands_23.ps", action = "write", status = "old")
        close (u_file, status = "delete")
     end if
     inquire (file = "commands_23.ps", exist = exist)
     write (u, "(1x,A,L1)")  "Postcript output exists = ", exist
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* TeX file"
     write (u, "(A)")
 
     inquire (file = "commands_23.tex", exist = exist)
     if (.not. exist) then
        write (u, "(A)")  "ERROR: File commands_23.tex not found"
        return
     end if
 
     u_file = free_unit ()
     open (u_file, file = "commands_23.tex", &
          action = "read", status = "old")
     do
        read (u_file, "(A)", iostat = iostat)  buffer
        if (iostat /= 0)  exit
        write (u, "(A)") trim (buffer)
     end do
     close (u_file)
     write (u, *)
 
     inquire (file = "commands_23.ps", exist = exist)
     write (u, "(1x,A,L1)")  "Postcript output exists = ", exist
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_23"
 
   end subroutine commands_23
 
 @ %def commands_23
 @
 \subsubsection{Histogram}
 Declare a histogram, fill it and display.
 <<Commands: execute tests>>=
   call test (commands_24, "commands_24", &
        "drawing options", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_24
 <<Commands: tests>>=
   subroutine commands_24 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_24"
     write (u, "(A)")  "*   Purpose: check graph and drawing options"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, '$title = "Title"')
     call ifile_append (ifile, '$description = "Description"')
     call ifile_append (ifile, '$x_label = "X Label"')
     call ifile_append (ifile, '$y_label = "Y Label"')
     call ifile_append (ifile, 'graph_width_mm = 111')
     call ifile_append (ifile, 'graph_height_mm = 222')
     call ifile_append (ifile, 'x_min = -11')
     call ifile_append (ifile, 'x_max = 22')
     call ifile_append (ifile, 'y_min = -33')
     call ifile_append (ifile, 'y_max = 44')
     call ifile_append (ifile, '$gmlcode_bg = "GML Code BG"')
     call ifile_append (ifile, '$gmlcode_fg = "GML Code FG"')
     call ifile_append (ifile, '$fill_options = "Fill Options"')
     call ifile_append (ifile, '$draw_options = "Draw Options"')
     call ifile_append (ifile, '$err_options = "Error Options"')
     call ifile_append (ifile, '$symbol = "Symbol"')
     call ifile_append (ifile, 'histogram foo (0,1)')
     call ifile_append (ifile, 'plot bar')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Display analysis store"
     write (u, "(A)")
 
     call analysis_write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_24"
 
   end subroutine commands_24
 
 @ %def commands_24
 @
 \subsubsection{Local Environment}
 Declare a local environment.
 <<Commands: execute tests>>=
   call test (commands_25, "commands_25", &
        "local process environment", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_25
 <<Commands: tests>>=
   subroutine commands_25 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_25"
     write (u, "(A)")  "*   Purpose: declare local environment for process"
     write (u, "(A)")
 
     call syntax_model_file_init ()
     call syntax_cmd_list_init ()
     call global%global_init ()
     call global%var_list%set_log (var_str ("?omega_openmp"), &
          .false., is_known = .true.)
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'library = "commands_25_lib"')
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process commands_25_p1 = g, g => g, g &
          &{ model = "QCD" }')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
     call global%write_libraries (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_25"
 
   end subroutine commands_25
 
 @ %def commands_25
 @
 \subsubsection{Alternative Setups}
 Declare a list of alternative setups.
 <<Commands: execute tests>>=
   call test (commands_26, "commands_26", &
        "alternative setups", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_26
 <<Commands: tests>>=
   subroutine commands_26 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_26"
     write (u, "(A)")  "*   Purpose: declare alternative setups for simulation"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'int i = 0')
     call ifile_append (ifile, 'alt_setup = ({ i = 1 }, { i = 2 })')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write_expr (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_26"
 
   end subroutine commands_26
 
 @ %def commands_26
 @
 \subsubsection{Unstable Particle}
 Define decay processes and declare a particle as unstable.  Also check
 the commands stable, polarized, unpolarized.
 <<Commands: execute tests>>=
   call test (commands_27, "commands_27", &
        "unstable and polarized particles", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_27
 <<Commands: tests>>=
   subroutine commands_27 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: commands_27"
     write (u, "(A)")  "*   Purpose: modify particle properties"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call global%global_init ()
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
     call global%var_list%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known=.true.)
     call global%var_list%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known=.true.)
     call global%var_list%set_log (var_str ("?vis_history"),&
          .false., is_known=.true.)
     call global%var_list%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
 
     allocate (lib)
     call lib%init (var_str ("commands_27_lib"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'ff = 0.4')
     call ifile_append (ifile, 'process d1 = s => f, fbar')
     call ifile_append (ifile, 'unstable s (d1)')
     call ifile_append (ifile, 'polarized f, fbar')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Show model"
     write (u, "(A)")
 
     call global%model%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extra Input"
     write (u, "(A)")
 
     call ifile_final (ifile)
     call ifile_append (ifile, '?diagonal_decay = true')
     call ifile_append (ifile, 'unstable s (d1)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%final ()
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Show model"
     write (u, "(A)")
 
     call global%model%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extra Input"
     write (u, "(A)")
 
     call ifile_final (ifile)
     call ifile_append (ifile, '?isotropic_decay = true')
     call ifile_append (ifile, 'unstable s (d1)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%final ()
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Show model"
     write (u, "(A)")
 
     call global%model%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extra Input"
     write (u, "(A)")
 
     call ifile_final (ifile)
     call ifile_append (ifile, 'stable s')
     call ifile_append (ifile, 'unpolarized f')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%final ()
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Show model"
     write (u, "(A)")
 
     call global%model%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_model_file_init ()
     call syntax_cmd_list_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_27"
 
   end subroutine commands_27
 
 @ %def commands_27
 @
 \subsubsection{Quit the program}
 Quit the program.
 <<Commands: execute tests>>=
   call test (commands_28, "commands_28", &
        "quit", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_28
 <<Commands: tests>>=
   subroutine commands_28 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root1, pn_root2
     type(string_t), dimension(0) :: no_vars
 
     write (u, "(A)")  "* Test output: commands_28"
     write (u, "(A)")  "*   Purpose: quit the program"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file: quit without code"
     write (u, "(A)")
 
     call ifile_append (ifile, 'quit')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root1, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root1, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write (u, vars = no_vars)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Input file: quit with code"
     write (u, "(A)")
 
     call ifile_final (ifile)
     call command_list%final ()
     call ifile_append (ifile, 'quit ( 3 + 4 )')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root2, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root2, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write (u, vars = no_vars)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_28"
 
   end subroutine commands_28
 
 @ %def commands_28
 @
 \subsubsection{SLHA interface}
 Testing commands steering the SLHA interface.
 <<Commands: execute tests>>=
   call test (commands_29, "commands_29", &
        "SLHA interface", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_29
 <<Commands: tests>>=
   subroutine commands_29 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(var_list_t), pointer :: model_vars
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_29"
     write (u, "(A)")  "*   Purpose: test SLHA interface"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call syntax_model_file_init ()
     call syntax_slha_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Model MSSM, read SLHA file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "MSSM"')
     call ifile_append (ifile, '?slha_read_decays = true')
     call ifile_append (ifile, 'read_slha ("sps1ap_decays.slha")')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Model MSSM, default values:"
     write (u, "(A)")
 
     call global%model%write (u, verbose = .false., &
          show_vertices = .false., show_particles = .false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Selected global variables"
     write (u, "(A)")
 
     model_vars => global%model%get_var_list_ptr ()
 
     call model_vars%write_var (var_str ("mch1"), u)
     call model_vars%write_var (var_str ("wch1"), u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")  "* Model MSSM, values from SLHA file"
     write (u, "(A)")
 
     call global%model%write (u, verbose = .false., &
          show_vertices = .false., show_particles = .false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Selected global variables"
     write (u, "(A)")
 
     model_vars => global%model%get_var_list_ptr ()
 
     call model_vars%write_var (var_str ("mch1"), u)
     call model_vars%write_var (var_str ("wch1"), u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_slha_final ()
     call syntax_model_file_final ()
     call syntax_cmd_list_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_29"
 
   end subroutine commands_29
 
 @ %def commands_29
 @
 \subsubsection{Expressions for scales}
 Declare a scale, factorization scale or factorization scale expression.
 <<Commands: execute tests>>=
   call test (commands_30, "commands_30", &
        "scales", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_30
 <<Commands: tests>>=
   subroutine commands_30 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_30"
     write (u, "(A)")  "*   Purpose: define scales"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'scale = 200 GeV')
     call ifile_append (ifile, &
          'factorization_scale = eval Pt [particle]')
     call ifile_append (ifile, &
          'renormalization_scale = eval E [particle]')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write_expr (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_30"
 
   end subroutine commands_30
 
 @ %def commands_30
 @
 \subsubsection{Weight and reweight expressions}
 Declare an expression for event weights and reweighting.
 <<Commands: execute tests>>=
   call test (commands_31, "commands_31", &
        "event weights/reweighting", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_31
 <<Commands: tests>>=
   subroutine commands_31 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_31"
     write (u, "(A)")  "*   Purpose: define weight/reweight"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'weight = eval Pz [particle]')
     call ifile_append (ifile, 'reweight = eval M2 [particle]')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write_expr (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_31"
 
   end subroutine commands_31
 
 @ %def commands_31
 @
 \subsubsection{Selecting events}
 Declare an expression for selecting events in an analysis.
 <<Commands: execute tests>>=
   call test (commands_32, "commands_32", &
        "event selection", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_32
 <<Commands: tests>>=
   subroutine commands_32 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
 
     write (u, "(A)")  "* Test output: commands_32"
     write (u, "(A)")  "*   Purpose: define selection"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'selection = any PDG == 13 [particle]')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     call global%write_expr (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_32"
 
   end subroutine commands_32
 
 @ %def commands_32
 @
 \subsubsection{Executing shell commands}
 Execute a shell command.
 <<Commands: execute tests>>=
   call test (commands_33, "commands_33", &
        "execute shell command", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_33
 <<Commands: tests>>=
   subroutine commands_33 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     integer :: u_file, iostat
     character(3) :: buffer
 
     write (u, "(A)")  "* Test output: commands_33"
     write (u, "(A)")  "*   Purpose: execute shell command"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     write (u, "(A)")  "*  Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'exec ("echo foo >> bar")')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
     u_file = free_unit ()
     open (u_file, file = "bar", &
          action = "read", status = "old")
     do
        read (u_file, "(A)", iostat = iostat)  buffer
        if (iostat /= 0) exit
     end do
     write (u, "(A,A)")  "should be 'foo': ", trim (buffer)
     close (u_file)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_33"
 
   end subroutine commands_33
 
 @ %def commands_33
 @
 \subsubsection{Callback}
 Instead of an explicit write, use the callback feature to write the
 analysis file during event generation.  We generate 4 events and
 arrange that the callback is executed while writing the 3rd event.
 <<Commands: execute tests>>=
   call test (commands_34, "commands_34", &
        "analysis via callback", &
        u, results)
 <<Commands: test declarations>>=
   public :: commands_34
 <<Commands: tests>>=
   subroutine commands_34 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(command_list_t), target :: command_list
     type(rt_data_t), target :: global
     type(parse_node_t), pointer :: pn_root
     type(prclib_entry_t), pointer :: lib
     type(event_callback_34_t) :: event_callback
 
     write (u, "(A)")  "* Test output: commands_34"
     write (u, "(A)")  "*   Purpose: write analysis data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization: create observable"
     write (u, "(A)")
 
     call syntax_cmd_list_init ()
     call global%global_init ()
 
     call syntax_model_file_init ()
     call global%global_init ()
     call global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
 
     call global%var_list%set_string (var_str ("$method"), &
          var_str ("unit_test"), is_known=.true.)
     call global%var_list%set_string (var_str ("$phs_method"), &
          var_str ("single"), is_known=.true.)
     call global%var_list%set_string (var_str ("$integration_method"),&
          var_str ("midpoint"), is_known=.true.)
     call global%var_list%set_real (var_str ("sqrts"), &
          1000._default, is_known=.true.)
     call global%var_list%set_log (var_str ("?vis_history"),&
          .false., is_known=.true.)
     call global%var_list%set_log (var_str ("?integration_timer"),&
          .false., is_known = .true.)
 
     allocate (lib)
     call lib%init (var_str ("lib_cmd34"))
     call global%add_prclib (lib)
 
     write (u, "(A)")  "* Prepare callback for writing analysis to I/O unit"
     write (u, "(A)")
 
     event_callback%u = u
     call global%set_event_callback (event_callback)
 
     write (u, "(A)")  "* Input file"
     write (u, "(A)")
 
     call ifile_append (ifile, 'model = "Test"')
     call ifile_append (ifile, 'process commands_34_p = s, s => s, s')
     call ifile_append (ifile, 'compile')
     call ifile_append (ifile, 'iterations = 1:1000')
     call ifile_append (ifile, 'integrate (commands_34_p)')
     call ifile_append (ifile, 'observable sq')
     call ifile_append (ifile, 'analysis = record sq (sqrts)')
     call ifile_append (ifile, 'n_events = 4')
     call ifile_append (ifile, 'event_callback_interval = 3')
     call ifile_append (ifile, 'simulate (commands_34_p)')
 
     call ifile_write (ifile, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Parse file"
     write (u, "(A)")
 
     call parse_ifile (ifile, pn_root)
 
     write (u, "(A)")  "* Compile command list"
     write (u, "(A)")
 
     call command_list%compile (pn_root, global)
 
     call command_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Execute command list"
     write (u, "(A)")
 
     call command_list%execute (global)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call ifile_final (ifile)
 
     call analysis_final ()
     call command_list%final ()
     call global%final ()
     call syntax_cmd_list_final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: commands_34"
 
   end subroutine commands_34
 
 @ %def commands_34
 @ For this test, we invent a callback object which simply writes the
 analysis file, using the standard call for this.  Here we rely on the
 fact that the analysis data are stored as a global entity, otherwise
 we would have to access them via the event object.
 <<Commands: test auxiliary types>>=
   type, extends (event_callback_t) :: event_callback_34_t
      private
      integer :: u = 0
    contains
      procedure :: write => event_callback_34_write
      procedure :: proc => event_callback_34
   end type event_callback_34_t
 
 @ %def event_callback_t
 @ The output routine is unused.  The actual callback should write the
 analysis data to the output unit that we have injected into the
 callback object.
 <<Commands: test auxiliary>>=
   subroutine event_callback_34_write (event_callback, unit)
     class(event_callback_34_t), intent(in) :: event_callback
     integer, intent(in), optional :: unit
   end subroutine event_callback_34_write
 
   subroutine event_callback_34 (event_callback, i, event)
     class(event_callback_34_t), intent(in) :: event_callback
     integer(i64), intent(in) :: i
     class(generic_event_t), intent(in) :: event
     call analysis_write (event_callback%u)
   end subroutine event_callback_34
 
 @ %def event_callback_34_write
 @ %def event_callback_34
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Toplevel module WHIZARD}
 <<[[whizard.f90]]>>=
 <<File header>>
 
 module whizard
 
   use io_units
 <<Use strings>>
   use system_defs, only: VERSION_STRING
   use system_defs, only: EOF, BACKSLASH
   use diagnostics
   use os_interface
   use ifiles
   use lexers
   use parser
   use eval_trees
   use models
   use phs_forests
   use prclib_stacks
   use slha_interface
   use blha_config
   use rt_data
   use commands
 
 <<Standard module head>>
 
 <<WHIZARD: public>>
 
 <<WHIZARD: types>>
 
 <<WHIZARD: variables>>
 
   save
 
 contains
 
 <<WHIZARD: procedures>>
 
 end module whizard
 @ %def whizard
 @
 \subsection{Options}
 Here we introduce a wrapper that holds various user options, so they
 can transparently be passed from the main program to the [[whizard]]
 object.  Most parameters are used for initializing the [[global]]
 state.
 <<WHIZARD: public>>=
   public :: whizard_options_t
 <<WHIZARD: types>>=
   type :: whizard_options_t
      type(string_t) :: job_id
      type(string_t), dimension(:), allocatable :: pack_args
      type(string_t), dimension(:), allocatable :: unpack_args
      type(string_t) :: preload_model
      type(string_t) :: default_lib
      type(string_t) :: preload_libraries
      logical :: rebuild_library = .false.
      logical :: recompile_library = .false.
      logical :: rebuild_phs = .false.
      logical :: rebuild_grids = .false.
      logical :: rebuild_events = .false.
   end type whizard_options_t
 
 @ %def whizard_options_t
 @
 \subsection{Parse tree stack}
 We collect all parse trees that we generate in the [[whizard]] object.  To
 this end, we create a stack of parse trees.  They must not be finalized before
 the [[global]] object is finalized, because items such as a cut definition may
 contain references to the parse tree from which they were generated.
 <<WHIZARD: types>>=
   type, extends (parse_tree_t) :: pt_entry_t
      type(pt_entry_t), pointer :: previous => null ()
   end type pt_entry_t
 
 @ %def pt_entry_t
 @ This is the stack.  Since we always prepend, we just need the [[last]]
 pointer.
 <<WHIZARD: types>>=
   type :: pt_stack_t
      type(pt_entry_t), pointer :: last => null ()
    contains
    <<WHIZARD: pt stack: TBP>>
   end type pt_stack_t
 
 @ %def pt_stack_t
 @ The finalizer is called at the very end.
 <<WHIZARD: pt stack: TBP>>=
   procedure :: final => pt_stack_final
 <<WHIZARD: procedures>>=
   subroutine pt_stack_final (pt_stack)
     class(pt_stack_t), intent(inout) :: pt_stack
     type(pt_entry_t), pointer :: current
     do while (associated (pt_stack%last))
        current => pt_stack%last
        pt_stack%last => current%previous
        call parse_tree_final (current%parse_tree_t)
        deallocate (current)
     end do
   end subroutine pt_stack_final
 
 @ %def pt_stack_final
 @ Create and push a new entry, keeping the previous ones.
 <<WHIZARD: pt stack: TBP>>=
   procedure :: push => pt_stack_push
 <<WHIZARD: procedures>>=
   subroutine pt_stack_push (pt_stack, parse_tree)
     class(pt_stack_t), intent(inout) :: pt_stack
     type(parse_tree_t), intent(out), pointer :: parse_tree
     type(pt_entry_t), pointer :: current
     allocate (current)
     parse_tree => current%parse_tree_t
     current%previous => pt_stack%last
     pt_stack%last => current
   end subroutine pt_stack_push
 
 @ %def pt_stack_push
 @
 \subsection{The [[whizard]] object}
 An object of type [[whizard_t]] is the top-level wrapper for a
 \whizard\ instance.  The object holds various default
 settings and the current state of the generator, the [[global]] object
 of type [[rt_data_t]].  This object contains, for instance, the list
 of variables and the process libraries.
 
 Since components of the [[global]] subobject are frequently used as
 targets, the [[whizard]] object should also consistently carry the
 [[target]] attribute.
 
 The various self-tests do no not use this object.  They initialize
 only specific subsets of the system, according to their needs.
 
 Note: we intend to allow several concurrent instances.  In the current
 implementation, there are still a few obstacles to this: the model
 library and the syntax tables are global variables, and the error
 handling uses global state.  This should be improved.
 <<WHIZARD: public>>=
   public :: whizard_t
 <<WHIZARD: types>>=
   type :: whizard_t
      type(whizard_options_t) :: options
      type(rt_data_t) :: global
      type(pt_stack_t) :: pt_stack
    contains
    <<WHIZARD: whizard: TBP>>
   end type whizard_t
 
 @ %def whizard_t
 @
 \subsection{Initialization and finalization}
 <<WHIZARD: whizard: TBP>>=
   procedure :: init => whizard_init
 <<WHIZARD: procedures>>=
   subroutine whizard_init (whizard, options, paths, logfile)
     class(whizard_t), intent(out), target :: whizard
     type(whizard_options_t), intent(in) :: options
     type(paths_t), intent(in), optional :: paths
     type(string_t), intent(in), optional :: logfile
     call init_syntax_tables ()
     whizard%options = options
     call whizard%global%global_init (paths, logfile)
     call whizard%init_job_id ()
     call whizard%init_rebuild_flags ()
     call whizard%unpack_files ()
     call whizard%preload_model ()
     call whizard%preload_library ()
     call whizard%global%init_fallback_model &
          (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
   end subroutine whizard_init
 
 @ %def whizard_init
 @ Apart from the global data which have been initialized above, the
 process and model lists need to be finalized.
 <<WHIZARD: whizard: TBP>>=
   procedure :: final => whizard_final
 <<WHIZARD: procedures>>=
   subroutine whizard_final (whizard)
     class(whizard_t), intent(inout), target :: whizard
     call whizard%global%final ()
     call whizard%pt_stack%final ()
     call whizard%pack_files ()
     call final_syntax_tables ()
   end subroutine whizard_final
 
 @ %def whizard_final
 @ Set the job ID, if nonempty.  If the ID string is empty, the value remains
 undefined.
 <<WHIZARD: whizard: TBP>>=
   procedure :: init_job_id => whizard_init_job_id
 <<WHIZARD: procedures>>=
   subroutine whizard_init_job_id (whizard)
     class(whizard_t), intent(inout), target :: whizard
     associate (var_list => whizard%global%var_list, options => whizard%options)
       if (options%job_id /= "") then
          call var_list%set_string (var_str ("$job_id"), &
               options%job_id, is_known=.true.)
       end if
     end associate
   end subroutine whizard_init_job_id
 
 @ %def whizard_init_job_id
 @
 Set the rebuild flags.  They can be specified on the command line and
 set the initial value for the associated logical variables.
 <<WHIZARD: whizard: TBP>>=
   procedure :: init_rebuild_flags => whizard_init_rebuild_flags
 <<WHIZARD: procedures>>=
   subroutine whizard_init_rebuild_flags (whizard)
     class(whizard_t), intent(inout), target :: whizard
     associate (var_list => whizard%global%var_list, options => whizard%options)
       call var_list%append_log (var_str ("?rebuild_library"), &
            options%rebuild_library, intrinsic=.true.)
       call var_list%append_log (var_str ("?recompile_library"), &
            options%recompile_library, intrinsic=.true.)
       call var_list%append_log (var_str ("?rebuild_phase_space"), &
            options%rebuild_phs, intrinsic=.true.)
       call var_list%append_log (var_str ("?rebuild_grids"), &
            options%rebuild_grids, intrinsic=.true.)
       call var_list%append_log (var_str ("?rebuild_events"), &
            options%rebuild_events, intrinsic=.true.)
     end associate
   end subroutine whizard_init_rebuild_flags
 
 @ %def whizard_init_rebuild_flags
 @
 Pack/unpack files in the working directory, if requested.
 <<WHIZARD: whizard: TBP>>=
   procedure :: pack_files => whizard_pack_files
   procedure :: unpack_files => whizard_unpack_files
 <<WHIZARD: procedures>>=
   subroutine whizard_pack_files (whizard)
     class(whizard_t), intent(in), target :: whizard
     logical :: exist
     integer :: i
     type(string_t) :: file
     if (allocated (whizard%options%pack_args)) then
        do i = 1, size (whizard%options%pack_args)
           file = whizard%options%pack_args(i)
           call msg_message ("Packing file/dir '" // char (file) // "'")
           exist = os_file_exist (file) .or. os_dir_exist (file)
           if (exist) then
              call os_pack_file (whizard%options%pack_args(i), &
                   whizard%global%os_data)
           else
              call msg_error ("File/dir '" // char (file) // "' not found")
           end if
        end do
     end if
   end subroutine whizard_pack_files
 
   subroutine whizard_unpack_files (whizard)
     class(whizard_t), intent(in), target :: whizard
     logical :: exist
     integer :: i
     type(string_t) :: file
     if (allocated (whizard%options%unpack_args)) then
        do i = 1, size (whizard%options%unpack_args)
           file = whizard%options%unpack_args(i)
           call msg_message ("Unpacking file '" // char (file) // "'")
           exist = os_file_exist (file)
           if (exist) then
              call os_unpack_file (whizard%options%unpack_args(i), &
                   whizard%global%os_data)
           else
              call msg_error ("File '" // char (file) // "' not found")
           end if
        end do
     end if
   end subroutine whizard_unpack_files
 
 @ %def whizard_pack_files
 @ %def whizard_unpack_files
 @
 This procedure preloads a model, if a model name is given.
 <<WHIZARD: whizard: TBP>>=
   procedure :: preload_model => whizard_preload_model
 <<WHIZARD: procedures>>=
   subroutine whizard_preload_model (whizard)
     class(whizard_t), intent(inout), target :: whizard
     type(string_t) :: model_name
     model_name = whizard%options%preload_model
     if (model_name /= "") then
        call whizard%global%read_model (model_name, whizard%global%preload_model)
        whizard%global%model => whizard%global%preload_model
        if (associated (whizard%global%model)) then
           call whizard%global%model%link_var_list (whizard%global%var_list)
           call whizard%global%var_list%set_string (var_str ("$model_name"), &
                model_name, is_known = .true.)
           call msg_message ("Preloaded model: " &
                // char (model_name))
        else
           call msg_fatal ("Preloading model " // char (model_name) &
                // " failed")
        end if
     else
        call msg_message ("No model preloaded")
     end if
   end subroutine whizard_preload_model
 
 @ %def whizard_preload_model
 @
 This procedure preloads a library, if a library name is given.
 
 Note: This version just opens a new library with that name.  It does not load
 (yet) an existing library on file, as previous \whizard\ versions would do.
 <<WHIZARD: whizard: TBP>>=
   procedure :: preload_library => whizard_preload_library
 <<WHIZARD: procedures>>=
   subroutine whizard_preload_library (whizard)
     class(whizard_t), intent(inout), target :: whizard
     type(string_t) :: library_name, libs
     type(string_t), dimension(:), allocatable :: libname_static
     type(prclib_entry_t), pointer :: lib_entry
     integer :: i
     call get_prclib_static (libname_static)
     do i = 1, size (libname_static)
        allocate (lib_entry)
        call lib_entry%init_static (libname_static(i))
        call whizard%global%add_prclib (lib_entry)
     end do
     libs = adjustl (whizard%options%preload_libraries)
     if (libs == "" .and. whizard%options%default_lib /= "") then
        allocate (lib_entry)
        call lib_entry%init (whizard%options%default_lib)
        call whizard%global%add_prclib (lib_entry)
        call msg_message ("Preloaded library: " // &
             char (whizard%options%default_lib))
     end if
     SCAN_LIBS: do while (libs /= "")
        call split (libs, library_name, " ")
        if (library_name /= "") then
           allocate (lib_entry)
           call lib_entry%init (library_name)
           call whizard%global%add_prclib (lib_entry)
           call msg_message ("Preloaded library: " // char (library_name))
        end if
     end do SCAN_LIBS
   end subroutine whizard_preload_library
 
 @ %def whizard_preload_library
 @
 \subsection{Initialization and finalization: syntax tables}
 Initialize/finalize the syntax tables used by WHIZARD.  These are effectively
 singleton objects.  We introduce a module variable that tracks the
 initialization status.
 
 Without syntax tables, essentially nothing will work.  Any initializer has to
 call this.
 <<WHIZARD: variables>>=
   logical :: syntax_tables_exist = .false.
 @ %def syntax_tables_exist
 @ 
 <<WHIZARD: public>>=
   public :: init_syntax_tables
   public :: final_syntax_tables
 <<WHIZARD: procedures>>=
   subroutine init_syntax_tables ()
     if (.not. syntax_tables_exist) then
        call syntax_model_file_init ()
        call syntax_phs_forest_init ()
        call syntax_pexpr_init ()
        call syntax_slha_init ()
        call syntax_cmd_list_init ()
        syntax_tables_exist = .true.
     end if
   end subroutine init_syntax_tables
 
   subroutine final_syntax_tables ()
     if (syntax_tables_exist) then
        call syntax_model_file_final ()
        call syntax_phs_forest_final ()
        call syntax_pexpr_final ()
        call syntax_slha_final ()
        call syntax_cmd_list_final ()
        syntax_tables_exist = .false.
     end if
   end subroutine final_syntax_tables
 
 @ %def init_syntax_tables
 @ %def final_syntax_tables
 @ Write the syntax tables to external files.
 <<WHIZARD: public>>=
   public :: write_syntax_tables
 <<WHIZARD: procedures>>=
   subroutine write_syntax_tables ()
     integer :: unit
     character(*), parameter :: file_model = "whizard.model_file.syntax"
     character(*), parameter :: file_phs = "whizard.phase_space_file.syntax"
     character(*), parameter :: file_pexpr = "whizard.prt_expressions.syntax"
     character(*), parameter :: file_slha = "whizard.slha.syntax"
     character(*), parameter :: file_sindarin = "whizard.sindarin.syntax"
     if (.not. syntax_tables_exist)  call init_syntax_tables ()
     unit = free_unit ()
     print *, "Writing file '" // file_model // "'"
     open (unit=unit, file=file_model, status="replace", action="write")
     write (unit, "(A)")  VERSION_STRING
     write (unit, "(A)")  "Syntax definition file: " // file_model
     call syntax_model_file_write (unit)
     close (unit)
     print *, "Writing file '" // file_phs // "'"
     open (unit=unit, file=file_phs, status="replace", action="write")
     write (unit, "(A)")  VERSION_STRING
     write (unit, "(A)")  "Syntax definition file: " // file_phs
     call syntax_phs_forest_write (unit)
     close (unit)
     print *, "Writing file '" // file_pexpr // "'"
     open (unit=unit, file=file_pexpr, status="replace", action="write")
     write (unit, "(A)")  VERSION_STRING
     write (unit, "(A)")  "Syntax definition file: " // file_pexpr
     call syntax_pexpr_write (unit)
     close (unit)
     print *, "Writing file '" // file_slha // "'"
     open (unit=unit, file=file_slha, status="replace", action="write")
     write (unit, "(A)")  VERSION_STRING
     write (unit, "(A)")  "Syntax definition file: " // file_slha
     call syntax_slha_write (unit)
     close (unit)
     print *, "Writing file '" // file_sindarin // "'"
     open (unit=unit, file=file_sindarin, status="replace", action="write")
     write (unit, "(A)")  VERSION_STRING
     write (unit, "(A)")  "Syntax definition file: " // file_sindarin
     call syntax_cmd_list_write (unit)
     close (unit)
   end subroutine write_syntax_tables
 
 @ %def write_syntax_tables
 @
 \subsection{Execute command lists}
 Process commands given on the command line, stored as an [[ifile]].  The whole
 input is read, compiled and executed as a whole.
 <<WHIZARD: whizard: TBP>>=
   procedure :: process_ifile => whizard_process_ifile
 <<WHIZARD: procedures>>=
   subroutine whizard_process_ifile (whizard, ifile, quit, quit_code)
     class(whizard_t), intent(inout), target :: whizard
     type(ifile_t), intent(in) :: ifile
     logical, intent(out) :: quit
     integer, intent(out) :: quit_code
     type(lexer_t), target :: lexer
     type(stream_t), target :: stream
     call msg_message ("Reading commands given on the command line")
     call lexer_init_cmd_list (lexer)
     call stream_init (stream, ifile)
     call whizard%process_stream (stream, lexer, quit, quit_code)
     call stream_final (stream)
     call lexer_final (lexer)
   end subroutine whizard_process_ifile
 
 @ %def whizard_process_ifile
 @ Process standard input as a command list.  The whole input is read,
 compiled and executed as a whole.
 <<WHIZARD: whizard: TBP>>=
   procedure :: process_stdin => whizard_process_stdin
 <<WHIZARD: procedures>>=
   subroutine whizard_process_stdin (whizard, quit, quit_code)
     class(whizard_t), intent(inout), target :: whizard
     logical, intent(out) :: quit
     integer, intent(out) :: quit_code
     type(lexer_t), target :: lexer
     type(stream_t), target :: stream
     call msg_message ("Reading commands from standard input")
     call lexer_init_cmd_list (lexer)
     call stream_init (stream, 5)
     call whizard%process_stream (stream, lexer, quit, quit_code)
     call stream_final (stream)
     call lexer_final (lexer)
   end subroutine whizard_process_stdin
 
 @ %def whizard_process_stdin
 @ Process a file as a command list.
 <<WHIZARD: whizard: TBP>>=
   procedure :: process_file => whizard_process_file
 <<WHIZARD: procedures>>=
   subroutine whizard_process_file (whizard, file, quit, quit_code)
     class(whizard_t), intent(inout), target :: whizard
     type(string_t), intent(in) :: file
     logical, intent(out) :: quit
     integer, intent(out) :: quit_code
     type(lexer_t), target :: lexer
     type(stream_t), target :: stream
     logical :: exist
     call msg_message ("Reading commands from file '" // char (file) // "'")
     inquire (file=char(file), exist=exist)
     if (exist) then
        call lexer_init_cmd_list (lexer)
        call stream_init (stream, char (file))
        call whizard%process_stream (stream, lexer, quit, quit_code)
        call stream_final (stream)
        call lexer_final (lexer)
     else
        call msg_error ("File '" // char (file) // "' not found")
     end if
   end subroutine whizard_process_file
 
 @ %def whizard_process_file
 @
 <<WHIZARD: whizard: TBP>>=
   procedure :: process_stream => whizard_process_stream
 <<WHIZARD: procedures>>=
   subroutine whizard_process_stream (whizard, stream, lexer, quit, quit_code)
     class(whizard_t), intent(inout), target :: whizard
     type(stream_t), intent(inout), target :: stream
     type(lexer_t), intent(inout), target :: lexer
     logical, intent(out) :: quit
     integer, intent(out) :: quit_code
     type(parse_tree_t), pointer :: parse_tree
     type(command_list_t), target :: command_list
     call lexer_assign_stream (lexer, stream)
     call whizard%pt_stack%push (parse_tree)
     call parse_tree_init (parse_tree, syntax_cmd_list, lexer)
     if (associated (parse_tree%get_root_ptr ())) then
        whizard%global%lexer => lexer
        call command_list%compile (parse_tree%get_root_ptr (), &
             whizard%global)
     end if
     call whizard%global%activate ()
     call command_list%execute (whizard%global)
     call command_list%final ()
     quit = whizard%global%quit
     quit_code = whizard%global%quit_code
   end subroutine whizard_process_stream
 
 @ %def whizard_process_stream
 @
 \subsection{The WHIZARD shell}
 This procedure implements interactive mode.  One line is processed at
 a time.
 <<WHIZARD: whizard: TBP>>=
   procedure :: shell => whizard_shell
 <<WHIZARD: procedures>>=
   subroutine whizard_shell (whizard, quit_code)
     class(whizard_t), intent(inout), target :: whizard
     integer, intent(out) :: quit_code
     type(lexer_t), target :: lexer
     type(stream_t), target :: stream
     type(string_t) :: prompt1
     type(string_t) :: prompt2
     type(string_t) :: input
     type(string_t) :: extra
     integer :: last
     integer :: iostat
     logical :: mask_tmp
     logical :: quit
     call msg_message ("Launching interactive shell")
     call lexer_init_cmd_list (lexer)
     prompt1 = "whish? "
     prompt2 = "     > "
     COMMAND_LOOP: do
        call put (6, prompt1)
        call get (5, input, iostat=iostat)
        if (iostat > 0 .or. iostat == EOF) exit COMMAND_LOOP
        CONTINUE_INPUT: do
           last = len_trim (input)
           if (extract (input, last, last) /= BACKSLASH)  exit CONTINUE_INPUT
           call put (6, prompt2)
           call get (5, extra, iostat=iostat)
           if (iostat > 0) exit COMMAND_LOOP
           input = replace (input, last, extra)
        end do CONTINUE_INPUT
        call stream_init (stream, input)
        mask_tmp = mask_fatal_errors
        mask_fatal_errors = .true.
        call whizard%process_stream (stream, lexer, quit, quit_code)
        msg_count = 0
        mask_fatal_errors = mask_tmp
        call stream_final (stream)
        if (quit)  exit COMMAND_LOOP
     end do COMMAND_LOOP
     print *
     call lexer_final (lexer)
   end subroutine whizard_shell
 
 @ %def whizard_shell
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Query Feature Support}
 This module accesses the various optional features (modules) that
 WHIZARD can support and repors on their availability.
 <<[[features.f90]]>>=
 module features
 
   use string_utils, only: lower_case
   use system_dependencies, only: WHIZARD_VERSION
 <<Features: dependencies>>
 
 <<Standard module head>>
 
 <<Features: public>>
 
 contains
 
 <<Features: procedures>>
 
 end module features
 @ %def features
 @
 \subsection{Output}
 <<Features: public>>=
   public :: print_features
 <<Features: procedures>>=
   subroutine print_features ()
     print "(A)", "WHIZARD " // WHIZARD_VERSION
     print "(A)", "Build configuration:"
   <<Features: config>>
     print "(A)", "Optional features available in this build:"
   <<Features: print>>
   end subroutine print_features
 
 @ %def print_features
 @
 \subsection{Query function}
 <<Features: procedures>>=
   subroutine check (feature, recognized, result, help)
     character(*), intent(in) :: feature
     logical, intent(out) :: recognized
     character(*), intent(out) :: result, help
     recognized = .true.
     result = "no"
     select case (lower_case (trim (feature)))
   <<Features: cases>>
     case default
        recognized = .false.
     end select
   end subroutine check
 
 @ %def check
 @ Print this result:
 <<Features: procedures>>=
   subroutine print_check (feature)
     character(*), intent(in) :: feature
     character(16) :: f
     logical :: recognized
     character(10) :: result
     character(48) :: help
     call check (feature, recognized, result, help)
     if (.not. recognized) then
        result = "unknown"
        help = ""
     end if
     f = feature
     print "(2x,A,1x,A,'(',A,')')", f, result, trim (help)
   end subroutine print_check
 
 @ %def print_check
 @
 \subsection{Basic configuration}
 <<Features: config>>=
   call print_check ("precision")
 <<Features: dependencies>>=
   use kinds, only: default
 <<Features: cases>>=
   case ("precision")
      write (result, "(I0)")  precision (1._default)
      help = "significant decimals of real/complex numbers"
 @
 \subsection{Optional features case by case}
 <<Features: print>>=
   call print_check ("OpenMP")
 <<Features: dependencies>>=
   use system_dependencies, only: openmp_is_active
 <<Features: cases>>=
   case ("openmp")
      if (openmp_is_active ()) then
         result = "yes"
      end if
      help = "OpenMP parallel execution"
 @
 <<Features: print>>=
   call print_check ("GoSam")
 <<Features: dependencies>>=
   use system_dependencies, only: GOSAM_AVAILABLE
 <<Features: cases>>=
   case ("gosam")
      if (GOSAM_AVAILABLE) then
         result = "yes"
      end if
      help = "external NLO matrix element provider"
 @
 <<Features: print>>=
   call print_check ("OpenLoops")
 <<Features: dependencies>>=
   use system_dependencies, only: OPENLOOPS_AVAILABLE
 <<Features: cases>>=
   case ("openloops")
      if (OPENLOOPS_AVAILABLE) then
         result = "yes"
      end if
      help = "external NLO matrix element provider"
 @
 <<Features: print>>=
   call print_check ("Recola")
 <<Features: dependencies>>=
   use system_dependencies, only: RECOLA_AVAILABLE
 <<Features: cases>>=
   case ("recola")
      if (RECOLA_AVAILABLE) then
         result = "yes"
      end if
      help = "external NLO matrix element provider"
 @
 <<Features: print>>=
   call print_check ("LHAPDF")
 <<Features: dependencies>>=
   use system_dependencies, only: LHAPDF5_AVAILABLE
   use system_dependencies, only: LHAPDF6_AVAILABLE
 <<Features: cases>>=
   case ("lhapdf")
      if (LHAPDF5_AVAILABLE) then
         result = "v5"
      else if (LHAPDF6_AVAILABLE) then
         result = "v6"
      end if
      help = "PDF library"
 @
 <<Features: print>>=
   call print_check ("HOPPET")
 <<Features: dependencies>>=
   use system_dependencies, only: HOPPET_AVAILABLE
 <<Features: cases>>=
   case ("hoppet")
      if (HOPPET_AVAILABLE) then
         result = "yes"
      end if
      help = "PDF evolution package"
 @
 <<Features: print>>=
   call print_check ("fastjet")
 <<Features: dependencies>>=
   use jets, only: fastjet_available
 <<Features: cases>>=
   case ("fastjet")
      if (fastjet_available ()) then
         result = "yes"
      end if
      help = "jet-clustering package"
 @
 <<Features: print>>=
   call print_check ("Pythia6")
 <<Features: dependencies>>=
   use system_dependencies, only: PYTHIA6_AVAILABLE
 <<Features: cases>>=
   case ("pythia6")
      if (PYTHIA6_AVAILABLE) then
         result = "yes"
      end if
      help = "direct access for shower/hadronization"
 @
 <<Features: print>>=
   call print_check ("Pythia8")
 <<Features: dependencies>>=
   use system_dependencies, only: PYTHIA8_AVAILABLE
 <<Features: cases>>=
   case ("pythia8")
      if (PYTHIA8_AVAILABLE) then
         result = "yes"
      end if
      help = "direct access for shower/hadronization"
 @
 <<Features: print>>=
   call print_check ("StdHEP")
 <<Features: cases>>=
   case ("stdhep")
      result = "yes"
      help = "event I/O format"
 @
 <<Features: print>>=
   call print_check ("HepMC")
 <<Features: dependencies>>=
   use hepmc_interface, only: hepmc_is_available
 <<Features: cases>>=
   case ("hepmc")
      if (hepmc_is_available ()) then
         result = "yes"
      end if
      help = "event I/O format"
 @
 <<Features: print>>=
   call print_check ("LCIO")
 <<Features: dependencies>>=
   use lcio_interface, only: lcio_is_available
 <<Features: cases>>=
   case ("lcio")
      if (lcio_is_available ()) then
         result = "yes"
      end if
      help = "event I/O format"
 @
 <<Features: print>>=
   call print_check ("MetaPost")
 <<Features: dependencies>>=
   use system_dependencies, only: EVENT_ANALYSIS
 <<Features: cases>>=
   case ("metapost")
      result = EVENT_ANALYSIS
      help = "graphical event analysis via LaTeX/MetaPost"
 @ 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Index: trunk/src/matrix_elements/matrix_elements.nw
===================================================================
--- trunk/src/matrix_elements/matrix_elements.nw	(revision 8444)
+++ trunk/src/matrix_elements/matrix_elements.nw	(revision 8445)
@@ -1,10206 +1,10208 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: matrix elements and process libraries
 \chapter{Matrix Element Handling}
 \includemodulegraph{matrix_elements}
 
 In this chapter, we support internal and external matrix elements:
 initialization, automatic generation where necessary, and numerical
 evaluation.  We provide the interface for code generation and linking.
 Matrix-element code is organized in processes and process libraries.
 \begin{description}
 \item[process\_constants]
   A record of static process properties, for easy transfer between
   various \whizard\ modules.
 \item[prclib\_interfaces]
   This module deals with matrix-element code which is accessible via
   external libraries (Fortran libraries or generic C-compatible
   libraries) and must either be generated by the program or provided
   by the user explicitly.
 
   The module defines and uses an abstract type [[prc_writer_t]] and two
   abstract extensions, one for a Fortran module and one for a C-compatible
   library.   The implementation provides the specific methods for writing the
   appropriate parts in external matrix element code.
 \item[prc\_core\_def]
   This module defines the abstract types [[prc_core_def_t]] and
   [[prc_driver_t]].  The implementation of the former provides the
   configuration for processes of a certain class, while the latter accesses
   the corresponding matrix element, in particular those generated by the
   appropriate [[prc_writer_t]] object.
 \item[process\_libraries]
   This module combines the functionality of
   the previous module with the means for holding processes definitions
   (the internal counterpart of appropriate declarations in the user
   interface), for handling matrix elements which do not need external
   code, and for accessing the matrix elements by the procedures for
   matrix-element evaluation, integration and event generation.
 \item[prclib\_stacks]
   Collect process libraries.
 \item[test\_me] This module provides a test implementation for the abstract
   types in the [[prc_core_def]] module.  The implementation is intended for
   self-tests of several later modules.  The implementation is internal, i.e.,
   no external code has is generated.
 \end{description}
 All data structures which are specific for a particular way of
 generating code or evaluating matrix element are kept abstract and
 thus generic.  Later modules such as [[prc_omega]] provide
 implementations, in the form of type extensions for the various
 abstract types.
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process data block}
 
 We define a simple transparent type that contains universal constant
 process data.  We will reference objects of this type for the
 phase-space setup, for interfacing with process libraries, for
 implementing matrix-element generation, and in the master
 process-handling module.
 <<[[process_constants.f90]]>>=
 <<File header>>
 
 module process_constants
 
 <<Use kinds>>
 <<Use strings>>
 
   use io_units, only: given_output_unit, free_unit
   use format_utils, only: write_integer_array
   use md5, only: md5sum
 
   use pdg_arrays
 
 <<Standard module head>>
 
 <<Process Constants: public>>
 
 <<Process Constants: types>>
 
 contains
 
 <<Process Constants: procedures>>
 
 end module process_constants
 @ %def process_constants
 @
 The data type is just a block of public objects, only elementary
 types, no type-bound procedures.
 <<Process Constants: public>>=
   public :: process_constants_t
 <<Process Constants: types>>=
   type :: process_constants_t
      type(string_t) :: id
      type(string_t) :: model_name
      character(32) :: md5sum = ""
      logical :: openmp_supported = .false.
      integer :: n_in  = 0
      integer :: n_out = 0
      integer :: n_flv = 0
      integer :: n_hel = 0
      integer :: n_col = 0
      integer :: n_cin = 0
      integer :: n_cf  = 0
      integer, dimension(:,:), allocatable :: flv_state
      integer, dimension(:,:), allocatable :: hel_state
      integer, dimension(:,:,:), allocatable :: col_state
      logical, dimension(:,:), allocatable :: ghost_flag
      complex(default), dimension(:), allocatable :: color_factors
      integer, dimension(:,:), allocatable :: cf_index
+     integer, dimension(:), allocatable :: eqv_flv_index
+     integer, dimension(:), allocatable :: eqv_hel_index
   contains
   <<Process Constants: process constants: TBP>>
   end type process_constants_t
 
 @ %def process_constants_t
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_n_tot => process_constants_get_n_tot
 <<Process Constants: procedures>>=
   elemental function process_constants_get_n_tot (prc_const) result (n_tot)
     integer :: n_tot
     class(process_constants_t), intent(in) :: prc_const
     n_tot = prc_const%n_in + prc_const%n_out
   end function process_constants_get_n_tot
 
 @ %def process_constants_get_n_tot
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_flv_state => process_constants_get_flv_state
 <<Process Constants: procedures>>=
   subroutine process_constants_get_flv_state (prc_const, flv_state)
     class(process_constants_t), intent(in) :: prc_const
     integer, dimension(:,:), allocatable, intent(out) :: flv_state
     allocate (flv_state (size (prc_const%flv_state, 1), &
          size (prc_const%flv_state, 2)))
     flv_state = prc_const%flv_state
   end subroutine process_constants_get_flv_state
 
 @ %def process_constants_get_flv_state
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_n_flv => process_constants_get_n_flv
 <<Process Constants: procedures>>=
   function process_constants_get_n_flv (data) result (n_flv)
     integer :: n_flv
     class(process_constants_t), intent(in) :: data
     n_flv = data%n_flv
   end function process_constants_get_n_flv
 
 @ %def process_constants_get_n_flv
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_n_hel => process_constants_get_n_hel
 <<Process Constants: procedures>>=
   function process_constants_get_n_hel (data) result (n_hel)
     integer :: n_hel
     class(process_constants_t), intent(in) :: data
     n_hel = data%n_hel
   end function process_constants_get_n_hel
 
 @ %def process_constants_get_n_flv
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_hel_state => process_constants_get_hel_state
 <<Process Constants: procedures>>=
   subroutine process_constants_get_hel_state (prc_const, hel_state)
     class(process_constants_t), intent(in) :: prc_const
     integer, dimension(:,:), allocatable, intent(out) :: hel_state
     allocate (hel_state (size (prc_const%hel_state, 1), &
          size (prc_const%hel_state, 2)))
     hel_state = prc_const%hel_state
   end subroutine process_constants_get_hel_state
 
 @ %def process_constants_get_hel_state
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_col_state => process_constants_get_col_state
 <<Process Constants: procedures>>=
   subroutine process_constants_get_col_state (prc_const, col_state)
     class(process_constants_t), intent(in) :: prc_const
     integer, dimension(:,:,:), allocatable, intent(out) :: col_state
     allocate (col_state (size (prc_const%col_state, 1), &
          size (prc_const%col_state, 2), size (prc_const%col_state, 3)))
     col_state = prc_const%col_state
   end subroutine process_constants_get_col_state
 
 @ %def process_constants_get_col_state
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_ghost_flag => process_constants_get_ghost_flag
 <<Process Constants: procedures>>=
   subroutine process_constants_get_ghost_flag (prc_const, ghost_flag)
     class(process_constants_t), intent(in) :: prc_const
     logical, dimension(:,:), allocatable, intent(out) :: ghost_flag
     allocate (ghost_flag (size (prc_const%ghost_flag, 1), &
          size (prc_const%ghost_flag, 2)))
     ghost_flag = prc_const%ghost_flag
   end subroutine process_constants_get_ghost_flag
 
 @ %def process_constants_get_ghost_flag
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_color_factors => process_constants_get_color_factors
 <<Process Constants: procedures>>=
   subroutine process_constants_get_color_factors (prc_const, col_facts)
     class(process_constants_t), intent(in) :: prc_const
     complex(default), dimension(:), allocatable, intent(out) :: col_facts
     allocate (col_facts (size (prc_const%color_factors)))
     col_facts = prc_const%color_factors
   end subroutine process_constants_get_color_factors
 
 @ %def process_constants_get_color_factors
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_cf_index => process_constants_get_cf_index
 <<Process Constants: procedures>>=
   subroutine process_constants_get_cf_index (prc_const, cf_index)
     class(process_constants_t), intent(in) :: prc_const
     integer, intent(out), dimension(:,:), allocatable :: cf_index
     allocate (cf_index (size (prc_const%cf_index, 1), &
          size (prc_const%cf_index, 2)))
     cf_index = prc_const%cf_index
   end subroutine process_constants_get_cf_index
 
 @ %def process_constants_get_cf_index
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: set_flv_state => process_constants_set_flv_state
 <<Process Constants: procedures>>=
   subroutine process_constants_set_flv_state (prc_const, flv_state)
     class(process_constants_t), intent(inout) :: prc_const
     integer, intent(in), dimension(:,:), allocatable :: flv_state
     if (allocated (prc_const%flv_state)) deallocate (prc_const%flv_state)
     allocate (prc_const%flv_state (size (flv_state, 1), &
          size (flv_state, 2)))
     prc_const%flv_state = flv_state
     prc_const%n_flv = size (flv_state, 2)
   end subroutine process_constants_set_flv_state
 
 @ %def process_constants_set_flv_state
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: set_col_state => process_constants_set_col_state
 <<Process Constants: procedures>>=
   subroutine process_constants_set_col_state (prc_const, col_state)
     class(process_constants_t), intent(inout) :: prc_const
     integer, intent(in), dimension(:,:,:), allocatable :: col_state
     allocate (prc_const%col_state (size (col_state, 1), &
          size (col_state, 2), size (col_state, 3)))
     prc_const%col_state = col_state
   end subroutine process_constants_set_col_state
 
 @ %def process_constants_set_col_state
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: set_cf_index => process_constants_set_cf_index
 <<Process Constants: procedures>>=
   subroutine process_constants_set_cf_index (prc_const, cf_index)
     class(process_constants_t), intent(inout) :: prc_const
     integer, dimension(:,:), intent(in), allocatable :: cf_index
     allocate (prc_const%cf_index (size (cf_index, 1), &
          size (cf_index, 2)))
     prc_const%cf_index = cf_index
   end subroutine process_constants_set_cf_index
 
 @ %def process_constants_set_cf_index
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: set_color_factors => process_constants_set_color_factors
 <<Process Constants: procedures>>=
   subroutine process_constants_set_color_factors (prc_const, color_factors)
     class(process_constants_t), intent(inout) :: prc_const
     complex(default), dimension(:), intent(in), allocatable :: color_factors
     allocate (prc_const%color_factors (size (color_factors)))
     prc_const%color_factors = color_factors
   end subroutine process_constants_set_color_factors
 
 @ %def process_constants_set_color_factors
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: set_ghost_flag => process_constants_set_ghost_flag
 <<Process Constants: procedures>>=
   subroutine process_constants_set_ghost_flag (prc_const, ghost_flag)
     class(process_constants_t), intent(inout) :: prc_const
     logical, dimension(:,:), allocatable, intent(in) :: ghost_flag
     allocate (prc_const%ghost_flag (size (ghost_flag, 1), &
          size (ghost_flag, 2)))
     prc_const%ghost_flag = ghost_flag
   end subroutine process_constants_set_ghost_flag
 @ %def process_constants_set_ghost_flag
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: get_pdg_in => process_constants_get_pdg_in
 <<Process Constants: procedures>>=
   function process_constants_get_pdg_in (prc_const) result (pdg_in)
     type(pdg_array_t), dimension(:), allocatable :: pdg_in
     class(process_constants_t), intent(in) :: prc_const
     type(pdg_array_t) :: pdg_tmp
     integer :: i
     allocate (pdg_in (prc_const%n_in))
     do i = 1, prc_const%n_in
        pdg_tmp = prc_const%flv_state(i,:)
        pdg_in(i) = sort_abs (pdg_tmp, unique = .true.)
     end do
   end function process_constants_get_pdg_in
 
 @ %def process_constants_get_pdg_in
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: compute_md5sum => process_constants_compute_md5sum
 <<Process Constants: procedures>>=
   subroutine process_constants_compute_md5sum (prc_const, include_id)
     class(process_constants_t), intent(inout) :: prc_const
     logical, intent(in) :: include_id
     integer :: unit
     unit = prc_const%fill_unit_for_md5sum (include_id)
     rewind (unit)
     prc_const%md5sum = md5sum (unit)
     close (unit)
   end subroutine process_constants_compute_md5sum
 
 @ %process_constants_compute_md5sum
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: fill_unit_for_md5sum => process_constants_fill_unit_for_md5sum
 <<Process Constants: procedures>>=
   function process_constants_fill_unit_for_md5sum (prc_const, include_id) result (unit)
     integer :: unit
     class(process_constants_t), intent(in) :: prc_const
     logical, intent(in) :: include_id
     integer :: i, j, k
     unit = free_unit ()
     open (unit, status="scratch", action="readwrite")
     if (include_id) write (unit, '(A)') char (prc_const%id)
     write (unit, '(A)') char (prc_const%model_name)
     write (unit, '(L1)') prc_const%openmp_supported
     write (unit, '(I0)') prc_const%n_in
     write (unit, '(I0)') prc_const%n_out
     write (unit, '(I0)') prc_const%n_flv
     write (unit, '(I0)') prc_const%n_hel
     write (unit, '(I0)') prc_const%n_col
     write (unit, '(I0)') prc_const%n_cin
     write (unit, '(I0)') prc_const%n_cf
     do i = 1, size (prc_const%flv_state, dim=1)
        do j = 1, size (prc_const%flv_state, dim=2)
           write (unit, '(I0)') prc_const%flv_state (i, j)
        end do
     end do
     do i = 1, size (prc_const%hel_state, dim=1)
        do j = 1, size (prc_const%hel_state, dim=2)
           write (unit, '(I0)') prc_const%hel_state (i, j)
        end do
     end do
     do i = 1, size (prc_const%col_state, dim=1)
        do j = 1, size (prc_const%col_state, dim=2)
           do k = 1, size (prc_const%col_state, dim=3)
              write (unit, '(I0)') prc_const%col_state (i, j, k)
           end do
       end do
     end do
     do i = 1, size (prc_const%ghost_flag, dim=1)
        do j = 1, size (prc_const%ghost_flag, dim=2)
           write (unit, '(L1)') prc_const%ghost_flag (i, j)
        end do
     end do
     do i = 1, size (prc_const%color_factors)
        write (unit, '(F0.0,F0.0)') real (prc_const%color_factors(i)), &
           aimag (prc_const%color_factors(i))
     end do
     do i = 1, size (prc_const%cf_index, dim=1)
        do j = 1, size (prc_const%cf_index, dim=2)
           write (unit, '(I0)') prc_const%cf_index(i, j)
        end do
     end do
   end function process_constants_fill_unit_for_md5sum
 
 @ %def process_constants_fill_unit_for_md5sum
 @
 <<Process Constants: process constants: TBP>>=
   procedure :: write => process_constants_write
 <<Process Constants: procedures>>=
   subroutine process_constants_write (prc_const, unit)
     class(process_constants_t), intent(in) :: prc_const
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A,A)") "Process data of id: ", char (prc_const%id)
     write (u, "(1x,A,A)") "Associated model: ", char (prc_const%model_name)
     write (u, "(1x,A,I0)") "n_in: ", prc_const%n_in
     write (u, "(1x,A,I0)") "n_out: ", prc_const%n_out
     write (u, "(1x,A,I0)") "n_flv: ", prc_const%n_flv
     write (u, "(1x,A,I0)") "n_hel: ", prc_const%n_hel
     write (u, "(1x,A,I0)") "n_col: ", prc_const%n_col
     write (u, "(1x,A,I0)") "n_cin: ", prc_const%n_cin
     write (u, "(1x,A,I0)") "n_cf: ", prc_const%n_cf
     write (u, "(1x,A)") "Flavors: "
     do i = 1, prc_const%n_flv
        write (u, "(1x,A,I0)") "i_flv: ", i
        call write_integer_array (prc_const%flv_state (:,i))
     end do
   end subroutine process_constants_write
 
 @ %def process_constants_write
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process library interface}
 
 The module [[prclib_interfaces]] handles external matrix-element code.
 
 
 \subsection{Overview}
 The top-level data structure is the [[prclib_driver_t]] data type.
 The associated type-bound procedures deal with the generation of
 external code, compilation and linking, and accessing the active
 external library.
 
 An object of type [[prclib_driver_t]] consists of the following parts:
 \begin{enumerate}
 \item\ Metadata that identify name and status of the library driver,
   etc.
 \item\ An array of process records ([[prclib_driver_record_t]]), one
   for each external matrix element.
 \item\ A record of type [[dlaccess_t]] which handles the
   operating-system part of linking a dynamically loadable library.
 \item\ A collection of procedure pointers which have a counterpart in
   the external library interface.  Given the unique identifier of a
   matrix element, the procedures retrieve generic matrix-element
   information such as the particle content and helicity combination
   tables.  There is also a procedure which returns pointers to the
   more specific procedures that a matrix element provides, called
   \emph{features}.
 \end{enumerate}
 
 The process records of type [[prclib_driver_record_t]] handle the
 individual matrix elements.  Each record identifies a process by name
 ([[id]]), names the physics model to be loaded for this process, lists
 the features that the associated matrix-element code provides, and
 holds a [[writer]] object which handles all operations that depend on
 the process type.  The numbering of process records is identical to
 the numbering of matrix-element codes in the external library.
 
 The writer object is of abstract type [[prc_writer_t]].  The module
 defines two basic, also abstract, extensions:
 [[prc_writer_f_module_t]] and [[prc_writer_c_lib_t]].  The first
 version is for matrix-element code that is available in form of
 Fortran modules.  The writer contains type-bound procedures which
 create appropriate [[use]] directives and [[C]]-compatible wrapper
 functions for the given set of Fortran modules and their features.
 The second version is for matrix-element code that is available in
 form of a C-compatible library (this includes Fortran libraries with
 proper C bindings).  The writer needs not write wrapper function, but
 explicit interface blocks for the matrix-element features.
 
 Each matrix-element variant is encoded in an appropriate extension of
 [[prc_writer_t]].  For instance, \oMega\ matrix elements provide an
 implementation [[omega_writer_t]] which extends
 [[prc_writer_f_module_t]].
 
 \subsection{Workflow}
 We expect that the functionality provided by this module is called in
 the following order:
 \begin{enumerate}
 \item
   The caller initializes the [[prclib_driver_t]] object and fills the
   array of [[prclib_record_t]] entries with the appropriate process
   data and process-specific writer objects.
 \item
   It calls the [[generate_makefile]] method to set up an appropriate
   makefile in the current directory.  The makefile will handle source
   generation, compilation and linking both for the individual matrix
   elements (unless this has to be done manually) and for the common
   external driver code which interfaces those matrix element.
 \item
   The [[generate_driver_code]] writes the common driver as source code
   to file.
 \item
   The methods [[make_source]], [[make_compile]], and [[make_link]]
   individually perform the corresponding steps in building the
   library.   Wherever possible, they simply use the generated makefile.
   By calling [[make]], we make sure that we can avoid
   unnecessary recompilation.  For the
   compilation and linking steps, the makefile will employ [[libtool]].
 \item
   The [[load]] method loads the library procedures into the
   corresponding procedure pointers, using the [[dlopen]] mechanism via
   the [[dlaccess]] subobject.
 \end{enumerate}
 
 \subsection{The module}
 <<[[prclib_interfaces.f90]]>>=
 <<File header>>
 
 module prclib_interfaces
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use kinds
 <<Use strings>>
   use io_units
   use system_defs, only: TAB
   use string_utils, only: lower_case
   use diagnostics
   use os_interface
 
 <<Standard module head>>
 
 <<Prclib interfaces: public>>
 
 <<Prclib interfaces: types>>
 
 <<Prclib interfaces: interfaces>>
 
 contains
 
 <<Prclib interfaces: procedures>>
 
 end module prclib_interfaces
 @ %def prclib_interfaces
 @
 \subsection{Writers}
 External matrix element code provides externally visible procedures,
 which we denote as \emph{features}.  The features consist of
 informational subroutines and functions which are mandatory (universal
 features) and matrix-element specific subroutines and functions
 (specific features).  The driver interfaces the
 generic features directly, while it returns the specific features in
 form of bind(C) procedure pointers to the caller.  For instance,
 function [[n_in]] is generic, while the matrix matrix-element value
 itself is specific.
 
 To implement these tasks, the driver needs [[use]] directives for
 Fortran module procedures, interface blocks for other external stuff,
 wrapper code, and Makefile snippets.
 
 \subsubsection{Generic writer}
 In the [[prc_writer_t]] data type, we collect the procedures which
 implement the writing tasks.  The type is abstract.  The
 concrete implementations are defined by an extension which is specific
 for the process type.
 
 The MD5 sum stored here should be the MD5 checksum of the current process
 component, which can be calculated once the process is configured completely.
 It can be used by implementations which work with external files, such as
 \oMega.
 <<Prclib interfaces: public>>=
   public :: prc_writer_t
 <<Prclib interfaces: types>>=
   type, abstract :: prc_writer_t
      character(32) :: md5sum = ""
    contains
    <<Prclib interfaces: prc writer: TBP>>
   end type prc_writer_t
 
 @ %def prc_writer_t
 @ In any case, it is useful to have a string representation of the
 writer type.  This must be implemented by all extensions.
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(get_const_string), nopass, deferred :: type_name
 <<Prclib interfaces: interfaces>>=
   abstract interface
      function get_const_string () result (string)
        import
        type(string_t) :: string
      end function get_const_string
   end interface
 
 @ %def get_const_string
 @ Return the name of a procedure that implements a given feature, as
 it is provided by the external matrix-element code.  For a reasonable
 default, we take the feature name unchanged.
 <<Prclib interfaces: prc writer: TBP>>=
   procedure, nopass :: get_procname => prc_writer_get_procname
 <<Prclib interfaces: procedures>>=
   function prc_writer_get_procname (feature) result (name)
     type(string_t) :: name
     type(string_t), intent(in) :: feature
     name = feature
   end function prc_writer_get_procname
 
 @ %def prc_writer_get_procname
 @ Return the name of a procedure that implements a given feature with
 the bind(C) property, so it can be accessed via a C procedure pointer and
 handled by dlopen.  We need this for all special features of a matrix
 element, since the interface has to return a C function pointer for it.
 For a default implementation, we prefix the external procedure name by
 the process ID.
 <<Prclib interfaces: prc writer: TBP>>=
   procedure :: get_c_procname => prc_writer_get_c_procname
 <<Prclib interfaces: procedures>>=
   function prc_writer_get_c_procname (writer, id, feature) result (name)
     class(prc_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id, feature
     type(string_t) :: name
     name = id // "_" // feature
   end function prc_writer_get_c_procname
 
 @ %def get_c_procname
 @ Common signature of code-writing procedures.  The procedure may
 use the process ID, and the feature name.
 (Not necessarily all of them.)
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine write_code_file (writer, id)
        import
        class(prc_writer_t), intent(in) :: writer
        type(string_t), intent(in) :: id
      end subroutine write_code_file
   end interface
 
   abstract interface
      subroutine write_code (writer, unit, id)
        import
        class(prc_writer_t), intent(in) :: writer
        integer, intent(in) :: unit
        type(string_t), intent(in) :: id
      end subroutine write_code
   end interface
 
   abstract interface
      subroutine write_code_os &
           (writer, unit, id, os_data, verbose, testflag)
        import
        class(prc_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
      end subroutine write_code_os
   end interface
 
   abstract interface
      subroutine write_feature_code (writer, unit, id, feature)
        import
        class(prc_writer_t), intent(in) :: writer
        integer, intent(in) :: unit
        type(string_t), intent(in) :: id, feature
      end subroutine write_feature_code
   end interface
 
 @ %def write_code write_feature_code
 @ There must be a procedure which writes an interface block for a
 given feature.  If the external matrix element is implemented as a
 Fortran module, this is required only for the specific features which
 are returned as procedure pointers.
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(write_feature_code), deferred :: write_interface
 @ %def write_interface
 @ There must also be a procedure which writes Makefile code which is
 specific for the current process, but not the feature.
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(write_code_os), deferred :: write_makefile_code
 @ %def write_makefile_code
 @ This procedure writes code process-specific source-code file
 (which need not be Fortran).  It is called before [[make]] [[source]] is
 called.  It may be a no-op, if the source code is
 generated by Make instead.
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(write_code_file), deferred :: write_source_code
 @ %def write_source_code
 @ This procedure is executed, once for each process, before (after)
 [[make]] [[compile]] is called, respectively.
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(write_code_file), deferred :: before_compile
   procedure(write_code_file), deferred :: after_compile
 @ %def before_compile
 @ %def after_compile
 @
 \subsubsection{Writer for Fortran-module matrix elements}
 If the matrix element is available as a Fortran module, we have
 specific requirements: (i) the features are imported via [[use]]
 directives, (ii) the specific features require bind(C) wrappers.
 
 The type is still abstract, all methods must be implemented explicitly
 for a specific matrix-element variant.
 <<Prclib interfaces: public>>=
   public :: prc_writer_f_module_t
 <<Prclib interfaces: types>>=
   type, extends (prc_writer_t), abstract :: prc_writer_f_module_t
    contains
    <<Prclib interfaces: prc writer f module: TBP>>
   end type prc_writer_f_module_t
 
 @ %def prc_writer_f_module_t
 @ Return the name of the Fortran module.  As a default
 implementation, we take the process ID unchanged.
 <<Prclib interfaces: prc writer f module: TBP>>=
   procedure, nopass :: get_module_name => prc_writer_get_module_name
 <<Prclib interfaces: procedures>>=
   function prc_writer_get_module_name (id) result (name)
     type(string_t) :: name
     type(string_t), intent(in) :: id
     name = id
   end function prc_writer_get_module_name
 
 @ %def prc_writer_get_module_name
 @ Write a [[use]] directive that associates the driver reference with
 the procedure in the matrix element code.  By default, we use the C
 name for this.
 <<Prclib interfaces: prc writer f module: TBP>>=
   procedure :: write_use_line => prc_writer_write_use_line
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_write_use_line (writer, unit, id, feature)
     class(prc_writer_f_module_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t) :: id, feature
     write (unit, "(2x,9A)")  "use ", char (writer%get_module_name (id)), &
          ", only: ", char (writer%get_c_procname (id, feature)), &
          " => ", char (writer%get_procname (feature))
   end subroutine prc_writer_write_use_line
 
 @ %def prc_writer_write_use_line
 @ Write a wrapper routine for a feature.  This also associates a C
 name the module procedure.  The details depend on the writer variant.
 <<Prclib interfaces: prc writer f module: TBP>>=
   procedure(prc_write_wrapper), deferred :: write_wrapper
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine prc_write_wrapper (writer, unit, id, feature)
        import
        class(prc_writer_f_module_t), intent(in) :: writer
        integer, intent(in) :: unit
        type(string_t), intent(in) :: id, feature
      end subroutine prc_write_wrapper
   end interface
 
 @ %def prc_write_wrapper
 @ This is used for testing only: initialize the writer with a specific MD5 sum
 string.
 <<Prclib interfaces: prc writer: TBP>>=
   procedure :: init_test => prc_writer_init_test
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_init_test (writer)
     class(prc_writer_t), intent(out) :: writer
     writer%md5sum = "1234567890abcdef1234567890abcdef"
   end subroutine prc_writer_init_test
 
 @ %def prc_writer_init_test
 @
 \subsubsection{Writer for C-library matrix elements}
 This applies if the matrix element is available as a C library or a Fortran
 library with bind(C) compatible interface.  We can use the basic
 version.
 
 The type is still abstract, all methods must be implemented explicitly
 for a specific matrix-element variant.
 <<Prclib interfaces: public>>=
   public :: prc_writer_c_lib_t
 <<Prclib interfaces: types>>=
   type, extends (prc_writer_t), abstract :: prc_writer_c_lib_t
    contains
    <<Prclib interfaces: prc writer c lib: TBP>>
   end type prc_writer_c_lib_t
 
 @ %def prc_writer_c_lib_t
 @
 \subsection{Process records in the library driver}
 A process record holds the process (component) [[ID]], the physics
 [[model_name]], and the array of [[feature]]s that are
 implemented by the corresponding matrix element code.
 
 The [[writer]] component holds procedures.  The procedures write
 source code for the current record, either for the driver or for the
 Makefile.
 <<Prclib interfaces: types>>=
   type :: prclib_driver_record_t
      type(string_t) :: id
      type(string_t) :: model_name
      type(string_t), dimension(:), allocatable :: feature
      class(prc_writer_t), pointer :: writer => null ()
    contains
    <<Prclib interfaces: prclib driver record: TBP>>
   end type prclib_driver_record_t
 
 @ %def prclib_driver_record
 @ Output routine.  We indent the output, so it smoothly integrates
 into the output routine for the whole driver.
 
 Note: the pointer [[writer]] is introduced as a workaround for a NAG compiler
 bug.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write => prclib_driver_record_write
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write (object, unit)
     class(prclib_driver_record_t), intent(in) :: object
     integer, intent(in) :: unit
     integer :: j
     class(prc_writer_t), pointer :: writer
     write (unit, "(3x,A,2x,'[',A,']')")  &
          char (object%id), char (object%model_name)
     if (allocated (object%feature)) then
        writer => object%writer
        write (unit, "(5x,A,A)", advance="no") &
             char (writer%type_name ()), ":"
        do j = 1, size (object%feature)
           write (unit, "(1x,A)", advance="no") &
                char (object%feature(j))
        end do
        write (unit, *)
     end if
   end subroutine prclib_driver_record_write
 
 @ %def prclib_driver_record_write
 @ Get the C procedure name for a feature.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: get_c_procname => prclib_driver_record_get_c_procname
 <<Prclib interfaces: procedures>>=
   function prclib_driver_record_get_c_procname (record, feature) result (name)
     type(string_t) :: name
     class(prclib_driver_record_t), intent(in) :: record
     type(string_t), intent(in) :: feature
     name = record%writer%get_c_procname (record%id, feature)
   end function prclib_driver_record_get_c_procname
 
 @ %def prclib_driver_record_get_c_procname
 @ Write a USE directive for a given feature.  Applies only if the
 record corresponds to a Fortran module.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_use_line => prclib_driver_record_write_use_line
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_use_line (record, unit, feature)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     type(string_t), intent(in) :: feature
     select type (writer => record%writer)
     class is (prc_writer_f_module_t)
        call writer%write_use_line (unit, record%id, feature)
     end select
   end subroutine prclib_driver_record_write_use_line
 
 @ %def prclib_driver_record_write_use_line
 @ The alternative: write an interface block for a given feature,
 unless the record corresponds to a Fortran module.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_interface => prclib_driver_record_write_interface
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_interface (record, unit, feature)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     type(string_t), intent(in) :: feature
     select type (writer => record%writer)
     class is (prc_writer_f_module_t)
     class default
        call writer%write_interface (unit, record%id, feature)
     end select
   end subroutine prclib_driver_record_write_interface
 
 @ %def prclib_driver_record_write_use_line
 @ Write all special feature interfaces for the current record.  Do
 this for all process variants.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_interfaces => prclib_driver_record_write_interfaces
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_interfaces (record, unit)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     integer :: i
     do i = 1, size (record%feature)
        call record%writer%write_interface (unit, record%id, record%feature(i))
     end do
   end subroutine prclib_driver_record_write_interfaces
 
 @ %def prclib_driver_record_write_interfaces
 @ Write the wrapper routines for this record, if it corresponds to a
 Fortran module.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_wrappers => prclib_driver_record_write_wrappers
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_wrappers (record, unit)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     integer :: i
     select type (writer => record%writer)
     class is (prc_writer_f_module_t)
        do i = 1, size (record%feature)
           call writer%write_wrapper (unit, record%id, record%feature(i))
        end do
     end select
   end subroutine prclib_driver_record_write_wrappers
 
 @ %def prclib_driver_record_write_wrappers
 @ Write the Makefile code for this record.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_makefile_code => prclib_driver_record_write_makefile_code
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_makefile_code &
        (record, unit, os_data, verbose, testflag)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: verbose
     logical, intent(in), optional :: testflag
     call record%writer%write_makefile_code &
          (unit, record%id, os_data, verbose, testflag)
   end subroutine prclib_driver_record_write_makefile_code
 
 @ %def prclib_driver_record_write_makefile_code
 @ Write source-code files for this record.  This can be used as an alternative
 to handling source code via Makefile.  In fact, this procedure is executed
 before [[make]] [[source]] is called.  Usually, does nothing.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_source_code => prclib_driver_record_write_source_code
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_source_code (record)
     class(prclib_driver_record_t), intent(in) :: record
     call record%writer%write_source_code (record%id)
   end subroutine prclib_driver_record_write_source_code
 
 @ %def prclib_driver_record_write_source_code
 @ Execute commands for this record that depend on the sources, so they
 cannot be included in the previous procedure.  This procedure is
 executed before (after) [[make]] [[compile]] is called, respectively.
 Usually, does nothing.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: before_compile => prclib_driver_record_before_compile
   procedure :: after_compile => prclib_driver_record_after_compile
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_before_compile (record)
     class(prclib_driver_record_t), intent(in) :: record
     call record%writer%before_compile (record%id)
   end subroutine prclib_driver_record_before_compile
 
   subroutine prclib_driver_record_after_compile (record)
     class(prclib_driver_record_t), intent(in) :: record
     call record%writer%after_compile (record%id)
   end subroutine prclib_driver_record_after_compile
 
 @ %def prclib_driver_record_before_compile
 @ %def prclib_driver_record_after_compile
 @
 \subsection{The process library driver object}
 A [[prclib_driver_t]] object provides the interface to external matrix element
 code.  The code is provided by an external library which is either
 statically or dynamically linked.
 
 The dynamic and static versions of the library are two different
 implementations of the abstract base type.
 
 The [[basename]] identifies the library, both by file names and by Fortran
 variable names.
 
 The [[loaded]] flag becomes true once all procedure pointers to the
 matrix element have been assigned.
 
 For a dynamical external library, the communication proceeds via a
 [[dlaccess]] object.
 
 [[n_processes]] is the number of external process code components that
 are referenced by this library.  The code is addressed by index ([[i_lib]]
 in the process library entry above).  This number should be equal to
 the number returned by [[get_n_prc]].
 
 For each external process, there is a separate [[record]] which holds
 the data that are needed for the driver parts which are specific
 for a given process component.  The actual pointers for the loaded
 library will be assigned elsewhere.
 
 The remainder is a collection of procedure pointers, which can be
 assigned once all external code has been compiled and linked.
 The procedure pointers all take a process component code
 index as an argument.  Most return information about the process
 component that should match the process definition.  The [[get_fptr]]
 procedures return a function pointer, which is the actual means to
 compute matrix elements or retrieve associated data.
 
 Finally, the [[unload_hook]] and [[reload_hook]] pointers allow for
 the insertion of additional code when a library is loaded.
 <<Prclib interfaces: public>>=
   public :: prclib_driver_t
 <<Prclib interfaces: types>>=
   type, abstract :: prclib_driver_t
      type(string_t) :: basename
      character(32) :: md5sum = ""
      logical :: loaded = .false.
      type(string_t) :: libname
      type(string_t) :: modellibs_ldflags
      integer :: n_processes = 0
      type(prclib_driver_record_t), dimension(:), allocatable :: record
      procedure(prc_get_n_processes), nopass, pointer :: &
           get_n_processes => null ()
      procedure(prc_get_stringptr), nopass, pointer :: &
           get_process_id_ptr => null ()
      procedure(prc_get_stringptr), nopass, pointer :: &
           get_model_name_ptr => null ()
      procedure(prc_get_stringptr), nopass, pointer :: &
           get_md5sum_ptr => null ()
      procedure(prc_get_log), nopass, pointer :: &
           get_openmp_status => null ()
      procedure(prc_get_int), nopass, pointer :: get_n_in  => null ()
      procedure(prc_get_int), nopass, pointer :: get_n_out => null ()
      procedure(prc_get_int), nopass, pointer :: get_n_flv => null ()
      procedure(prc_get_int), nopass, pointer :: get_n_hel => null ()
      procedure(prc_get_int), nopass, pointer :: get_n_col => null ()
      procedure(prc_get_int), nopass, pointer :: get_n_cin => null ()
      procedure(prc_get_int), nopass, pointer :: get_n_cf  => null ()
      procedure(prc_set_int_tab1), nopass, pointer :: &
           set_flv_state_ptr => null ()
      procedure(prc_set_int_tab1), nopass, pointer :: &
           set_hel_state_ptr => null ()
      procedure(prc_set_col_state), nopass, pointer :: &
           set_col_state_ptr => null ()
      procedure(prc_set_color_factors), nopass, pointer :: &
           set_color_factors_ptr => null ()
      procedure(prc_get_fptr), nopass, pointer :: get_fptr => null ()
    contains
    <<Prclib interfaces: prclib driver: TBP>>
   end type prclib_driver_t
 
 @ %def prclib_driver_t
 @ This is the dynamic version.  It contains a [[dlaccess]] object for
 communicating with the OS.
 <<Prclib interfaces: public>>=
   public :: prclib_driver_dynamic_t
 <<Prclib interfaces: types>>=
   type, extends (prclib_driver_t) :: prclib_driver_dynamic_t
      type(dlaccess_t) :: dlaccess
    contains
    <<Prclib interfaces: prclib driver dynamic: TBP>>
   end type prclib_driver_dynamic_t
 
 @ %def prclib_driver_dynamic_t
 @ Print just the metadata.  Procedure pointers cannot be printed.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write => prclib_driver_write
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_write (object, unit, libpath)
     class(prclib_driver_t), intent(in) :: object
     integer, intent(in) :: unit
     logical, intent(in), optional :: libpath
     logical :: write_lib
     integer :: i
     write_lib = .true.
     if (present (libpath))  write_lib = libpath
     write (unit, "(1x,A,A)")  &
          "External matrix-element code library: ", char (object%basename)
     select type (object)
     type is (prclib_driver_dynamic_t)
        write (unit, "(3x,A,L1)")  "static    = F"
     class default
        write (unit, "(3x,A,L1)")  "static    = T"
     end select
     write (unit, "(3x,A,L1)")  "loaded    = ", object%loaded
     write (unit, "(3x,A,A,A)") "MD5 sum   = '", object%md5sum, "'"
     if (write_lib) then
        write (unit, "(3x,A,A,A)") "Mdl flags = '", &
             char (object%modellibs_ldflags), "'"
     end if
     select type (object)
     type is (prclib_driver_dynamic_t)
        write (unit, *)
        call object%dlaccess%write (unit)
     end select
     write (unit, *)
     if (allocated (object%record)) then
        write (unit, "(1x,A)")  "Matrix-element code entries:"
        do i = 1, object%n_processes
           call object%record(i)%write (unit)
        end do
     else
        write (unit, "(1x,A)")  "Matrix-element code entries: [undefined]"
     end if
   end subroutine prclib_driver_write
 
 @ %def prclib_driver_write
 @ Allocate a library as either static or dynamic.  For static
 libraries, the procedure defers control to an external procedure which
 knows about the available static libraries.  By default, this
 procedure is empty, but when we build a stand-alone executable, we
 replace the dummy by an actual dispatcher for the available
 static libraries.  If the static dispatcher was not successful, we
 allocate a dynamic library.
 
 The default version of [[dispatch_prclib_static]] resides in the
 [[prebuilt]] section of the \whizard\ tree, in a separate
 library.  It does nothing, but can be replaced by a different
 procedure that allocates a static library driver if requested by name.
 <<Prclib interfaces: public>>=
   public :: dispatch_prclib_driver
 <<Prclib interfaces: procedures>>=
   subroutine dispatch_prclib_driver &
        (driver, basename, modellibs_ldflags)
     class(prclib_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     type(string_t), intent(in), optional :: modellibs_ldflags
     procedure(dispatch_prclib_driver) :: dispatch_prclib_static
     if (allocated (driver))  deallocate (driver)
     call dispatch_prclib_static (driver, basename)
     if (.not. allocated (driver)) then
        allocate (prclib_driver_dynamic_t :: driver)
     end if
     driver%basename = basename
     driver%modellibs_ldflags = modellibs_ldflags
   end subroutine dispatch_prclib_driver
 
 @ %def dispatch_prclib_driver
 @ Initialize the ID array and set [[n_processes]] accordingly.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: init => prclib_driver_init
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_init (driver, n_processes)
     class(prclib_driver_t), intent(inout) :: driver
     integer, intent(in) :: n_processes
     driver%n_processes = n_processes
     allocate (driver%record (n_processes))
   end subroutine prclib_driver_init
 
 @ %def prclib_driver_init
 @ Set the MD5 sum.  This is separate because the MD5 sum may be known only
 after initialization.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: set_md5sum => prclib_driver_set_md5sum
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_set_md5sum (driver, md5sum)
     class(prclib_driver_t), intent(inout) :: driver
     character(32), intent(in) :: md5sum
     driver%md5sum = md5sum
   end subroutine prclib_driver_set_md5sum
 
 @ %def prclib_driver_set_md5sum
 @ Set the process record for a specific library entry.  If the index
 is zero, we do nothing.
 
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: set_record => prclib_driver_set_record
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_set_record (driver, i, &
        id, model_name, features, writer)
     class(prclib_driver_t), intent(inout) :: driver
     integer, intent(in) :: i
     type(string_t), intent(in) :: id
     type(string_t), intent(in) :: model_name
     type(string_t), dimension(:), intent(in) :: features
     class(prc_writer_t), intent(in), pointer :: writer
     if (i > 0) then
        associate (record => driver%record(i))
          record%id = id
          record%model_name = model_name
          allocate (record%feature (size (features)))
          record%feature = features
          record%writer => writer
        end associate
     end if
   end subroutine prclib_driver_set_record
 
 @ %def prclib_driver_set_record
 @ Write all USE directives for a given feature, scanning the array of
 processes.  Only Fortran-module processes count.  Then, write
 interface blocks for the remaining processes.
 
 The [[implicit none]] statement must go in-between.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_interfaces => prclib_driver_write_interfaces
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_write_interfaces (driver, unit, feature)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: feature
     integer :: i
     do i = 1, driver%n_processes
        call driver%record(i)%write_use_line (unit, feature)
     end do
     write (unit, "(2x,9A)")  "implicit none"
     do i = 1, driver%n_processes
        call driver%record(i)%write_interface (unit, feature)
     end do
   end subroutine prclib_driver_write_interfaces
 
 @ %def prclib_driver_write_interfaces
 @
 \subsection{Write makefile}
 The makefile contains constant parts, parts that depend on the library
 name, and parts that depend on the specific processes and their types.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: generate_makefile => prclib_driver_generate_makefile
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_generate_makefile (driver, unit, os_data, verbose, testflag)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: verbose
     logical, intent(in), optional :: testflag
     integer :: i
     write (unit, "(A)")  "# WHIZARD: Makefile for process library '" &
          // char (driver%basename) // "'"
     write (unit, "(A)")  "# Automatically generated file, do not edit"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Integrity check (don't modify the following line!)"
     write (unit, "(A)")  "MD5SUM = '" // driver%md5sum // "'"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Library name"
     write (unit, "(A)")  "BASE = " // char (driver%basename)
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Compiler"
     write (unit, "(A)")  "FC = " // char (os_data%fc)
     write (unit, "(A)")  "CC = " // char (os_data%cc)
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Included libraries"
     write (unit, "(A)")  "FCINCL = " // char (os_data%whizard_includes)
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Compiler flags"
     write (unit, "(A)")  "FCFLAGS = " // char (os_data%fcflags)
     write (unit, "(A)")  "FCFLAGS_PIC = " // char (os_data%fcflags_pic)
     write (unit, "(A)")  "CFLAGS = " // char (os_data%cflags)
     write (unit, "(A)")  "CFLAGS_PIC = " // char (os_data%cflags_pic)
     write (unit, "(A)")  "LDFLAGS = " // char (os_data%whizard_ldflags) &
          // " " // char (os_data%ldflags) // " " // &
          char (driver%modellibs_ldflags)
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# LaTeX setup"
     write (unit, "(A)")  "LATEX = " // char (os_data%latex)
     write (unit, "(A)")  "MPOST = " // char (os_data%mpost)
     write (unit, "(A)")  "DVIPS = " // char (os_data%dvips)
     write (unit, "(A)")  "PS2PDF = " // char (os_data%ps2pdf)
     write (unit, "(A)")  'TEX_FLAGS = "$$TEXINPUTS:' // &
          char(os_data%whizard_texpath) // '"'
     write (unit, "(A)")  'MP_FLAGS  = "$$MPINPUTS:' // &
          char(os_data%whizard_texpath) // '"'
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Libtool"
     write (unit, "(A)")  "LIBTOOL = " // char (os_data%whizard_libtool)
     if (verbose) then
        write (unit, "(A)")  "FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile"
        write (unit, "(A)")  "CCOMPILE = $(LIBTOOL) --tag=CC --mode=compile"
        write (unit, "(A)")  "LINK = $(LIBTOOL) --tag=FC --mode=link"
     else
        write (unit, "(A)")  "FCOMPILE = @$(LIBTOOL) --silent --tag=FC --mode=compile"
        write (unit, "(A)")  "CCOMPILE = @$(LIBTOOL) --silent --tag=CC --mode=compile"
        write (unit, "(A)")  "LINK = @$(LIBTOOL) --silent --tag=FC --mode=link"
     end if
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Compile commands (default)"
     write (unit, "(A)")  "LTFCOMPILE = $(FCOMPILE) $(FC) -c &
          &$(FCINCL) $(FCFLAGS) $(FCFLAGS_PIC)"
     write (unit, "(A)")  "LTCCOMPILE = $(CCOMPILE) $(CC) -c &
          &$(CFLAGS) $(CFLAGS_PIC)"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Default target"
     write (unit, "(A)")  "all: link diags"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Matrix-element code files"
     do i = 1, size (driver%record)
        call driver%record(i)%write_makefile_code (unit, os_data, verbose, testflag)
     end do
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Library driver"
     write (unit, "(A)")  "$(BASE).lo: $(BASE).f90 $(OBJECTS)"
     write (unit, "(A)")  TAB // "$(LTFCOMPILE) $<"
     if (.not. verbose) then
        write (unit, "(A)")  TAB // '@echo  "  FC       " $@'
     end if
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Library"
     write (unit, "(A)")  "$(BASE).la: $(BASE).lo $(OBJECTS)"
     if (.not. verbose) then
        write (unit, "(A)")  TAB // '@echo  "  FCLD     " $@'
     end if
     write (unit, "(A)")  TAB // "$(LINK) $(FC) -module -rpath /dev/null &
          &$(FCFLAGS) $(LDFLAGS) -o $(BASE).la $^"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Main targets"
     write (unit, "(A)")  "link: compile $(BASE).la"
     write (unit, "(A)")  "compile: source $(OBJECTS) $(TEX_OBJECTS) $(BASE).lo"
     write (unit, "(A)")  "compile_tex: $(TEX_OBJECTS)"
     write (unit, "(A)")  "source: $(SOURCES) $(BASE).f90 $(TEX_SOURCES)"
     write (unit, "(A)")  ".PHONY: link diags compile compile_tex source"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Specific cleanup targets"
     do i = 1, size (driver%record)
        write (unit, "(A)")  "clean-" // char (driver%record(i)%id) // ":"
        write (unit, "(A)")  ".PHONY: clean-" // char (driver%record(i)%id)
     end do
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# Generic cleanup targets"
     write (unit, "(A)")  "clean-library:"
     if (verbose) then
        write (unit, "(A)")  TAB // "rm -f $(BASE).la"
     else
        write (unit, "(A)")  TAB // '@echo  "  RM        $(BASE).la"'
        write (unit, "(A)")  TAB // "@rm -f $(BASE).la"
     end if
     write (unit, "(A)")  "clean-objects:"
     if (verbose) then
        write (unit, "(A)")  TAB // "rm -f $(BASE).lo $(BASE)_driver.mod &
             &$(CLEAN_OBJECTS)"
     else
        write (unit, "(A)")  TAB // '@echo  "  RM        $(BASE).lo &
             &$(BASE)_driver.mod $(CLEAN_OBJECTS)"'
        write (unit, "(A)")  TAB // "@rm -f $(BASE).lo $(BASE)_driver.mod &
             &$(CLEAN_OBJECTS)"
     end if
     write (unit, "(A)")  "clean-source:"
     if (verbose) then
        write (unit, "(A)")  TAB // "rm -f $(CLEAN_SOURCES)"
     else
        write (unit, "(A)")  TAB // '@echo  "  RM        $(CLEAN_SOURCES)"'
        write (unit, "(A)")  TAB // "@rm -f $(CLEAN_SOURCES)"
     end if
     write (unit, "(A)")  "clean-driver:"
     if (verbose) then
        write (unit, "(A)")  TAB // "rm -f $(BASE).f90"
     else
        write (unit, "(A)")  TAB // '@echo  "  RM        $(BASE).f90"'
        write (unit, "(A)")  TAB // "@rm -f $(BASE).f90"
     end if
     write (unit, "(A)")  "clean-makefile:"
     if (verbose) then
        write (unit, "(A)")  TAB // "rm -f $(BASE).makefile"
     else
        write (unit, "(A)")  TAB // '@echo  "  RM        $(BASE).makefile"'
        write (unit, "(A)")  TAB // "@rm -f $(BASE).makefile"
     end if
     write (unit, "(A)")  ".PHONY: clean-library clean-objects &
          &clean-source clean-driver clean-makefile"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "clean: clean-library clean-objects clean-source"
     write (unit, "(A)")  "distclean: clean clean-driver clean-makefile"
     write (unit, "(A)")  ".PHONY: clean distclean"
   end subroutine prclib_driver_generate_makefile
 
 @ %def prclib_driver_generate_makefile
 @
 \subsection{Write driver file}
 This procedure writes the process library driver source code to the
 specified output unit.  The individual routines for writing
 source-code procedures are given below.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: generate_driver_code => prclib_driver_generate_code
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_generate_code (driver, unit)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t) :: prefix
     integer :: i
 
     prefix = driver%basename // "_"
 
     write (unit, "(A)")  "! WHIZARD matrix-element code interface"
     write (unit, "(A)")  "!"
     write (unit, "(A)")  "! Automatically generated file, do not edit"
     call driver%write_module (unit, prefix)
     call driver%write_lib_md5sum_fun (unit, prefix)
     call driver%write_get_n_processes_fun (unit, prefix)
     call driver%write_get_process_id_fun (unit, prefix)
     call driver%write_get_model_name_fun (unit, prefix)
     call driver%write_get_md5sum_fun (unit, prefix)
     call driver%write_string_to_array_fun (unit, prefix)
     call driver%write_get_openmp_status_fun (unit, prefix)
     call driver%write_get_int_fun (unit, prefix, var_str ("n_in"))
     call driver%write_get_int_fun (unit, prefix, var_str ("n_out"))
     call driver%write_get_int_fun (unit, prefix, var_str ("n_flv"))
     call driver%write_get_int_fun (unit, prefix, var_str ("n_hel"))
     call driver%write_get_int_fun (unit, prefix, var_str ("n_col"))
     call driver%write_get_int_fun (unit, prefix, var_str ("n_cin"))
     call driver%write_get_int_fun (unit, prefix, var_str ("n_cf"))
     call driver%write_set_int_sub (unit, prefix, var_str ("flv_state"))
     call driver%write_set_int_sub (unit, prefix, var_str ("hel_state"))
     call driver%write_set_col_state_sub (unit, prefix)
     call driver%write_set_color_factors_sub (unit, prefix)
     call driver%write_get_fptr_sub (unit, prefix)
     do i = 1, driver%n_processes
        call driver%record(i)%write_wrappers (unit)
     end do
   end subroutine prclib_driver_generate_code
 
 @ %def prclib_driver_generate_code
 @ The driver module is used and required \emph{only} if we intend to
 link the library statically.  Then, it provides the (static) driver
 type as a concrete implementation of the abstract library driver.
 This type contains the internal dispatcher for assigning the library
 procedures to their appropriate procedure pointers.  In the dynamical
 case, the assignment is done via the base-type dispatcher which invokes
 the DL mechanism.
 
 However, compiling this together with the rest in any case should not
 do any harm.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure, nopass :: write_module => prclib_driver_write_module
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_write_module (unit, prefix)
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Module: define library driver as an extension &
          &of the abstract driver type."
     write (unit, "(A)")  "! This is used _only_ by the library dispatcher &
          &of a static executable."
     write (unit, "(A)")  "! For a dynamical library, the stand-alone proce&
          &dures are linked via libdl."
     write (unit, "(A)")  ""
     write (unit, "(A)")  "module " &
          // char (prefix) // "driver"
     write (unit, "(A)")  "  use iso_c_binding"
     write (unit, "(A)")  "  use iso_varying_string, string_t => varying_string"
     write (unit, "(A)")  "  use diagnostics"
     write (unit, "(A)")  "  use prclib_interfaces"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "  implicit none"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "  type, extends (prclib_driver_t) :: " &
          // char (prefix) // "driver_t"
     write (unit, "(A)")  "   contains"
     write (unit, "(A)")  "     procedure :: get_c_funptr => " &
          // char (prefix) // "driver_get_c_funptr"
     write (unit, "(A)")  "  end type " &
          // char (prefix) // "driver_t"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "contains"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "  function " &
          // char (prefix) // "driver_get_c_funptr (driver, feature) result &
          &(c_fptr)"
     write (unit, "(A)")  "    class(" &
          // char (prefix) // "driver_t), intent(inout) :: driver"
     write (unit, "(A)")  "    type(string_t), intent(in) :: feature"
     write (unit, "(A)")  "    type(c_funptr) :: c_fptr"
     call write_decl ("get_n_processes", "get_n_processes")
     call write_decl ("get_stringptr", "get_process_id_ptr")
     call write_decl ("get_stringptr", "get_model_name_ptr")
     call write_decl ("get_stringptr", "get_md5sum_ptr")
     call write_decl ("get_log", "get_openmp_status")
     call write_decl ("get_int", "get_n_in")
     call write_decl ("get_int", "get_n_out")
     call write_decl ("get_int", "get_n_flv")
     call write_decl ("get_int", "get_n_hel")
     call write_decl ("get_int", "get_n_col")
     call write_decl ("get_int", "get_n_cin")
     call write_decl ("get_int", "get_n_cf")
     call write_decl ("set_int_tab1", "set_flv_state_ptr")
     call write_decl ("set_int_tab1", "set_hel_state_ptr")
     call write_decl ("set_col_state", "set_col_state_ptr")
     call write_decl ("set_color_factors", "set_color_factors_ptr")
     call write_decl ("get_fptr", "get_fptr")
     write (unit, "(A)")  "    select case (char (feature))"
     call write_case ("get_n_processes")
     call write_case ("get_process_id_ptr")
     call write_case ("get_model_name_ptr")
     call write_case ("get_md5sum_ptr")
     call write_case ("get_openmp_status")
     call write_case ("get_n_in")
     call write_case ("get_n_out")
     call write_case ("get_n_flv")
     call write_case ("get_n_hel")
     call write_case ("get_n_col")
     call write_case ("get_n_cin")
     call write_case ("get_n_cf")
     call write_case ("set_flv_state_ptr")
     call write_case ("set_hel_state_ptr")
     call write_case ("set_col_state_ptr")
     call write_case ("set_color_factors_ptr")
     call write_case ("get_fptr")
     write (unit, "(A)")  "    case default"
     write (unit, "(A)")  "       call msg_bug ('prclib2 driver setup: unknown &
          &function name')"
     write (unit, "(A)")  "    end select"
     write (unit, "(A)")  "  end function " &
          // char (prefix) // "driver_get_c_funptr"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "end module " &
          // char (prefix) // "driver"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Stand-alone external procedures: used for both &
          &static and dynamic linkage"
   contains
     subroutine write_decl (template, feature)
       character(*), intent(in) :: template, feature
       write (unit, "(A)")  "    procedure(prc_" // template // ") &"
       write (unit, "(A)")  "         :: " &
            // char (prefix) // feature
     end subroutine write_decl
     subroutine write_case (feature)
       character(*), intent(in) :: feature
       write (unit, "(A)")  "    case ('" // feature // "')"
       write (unit, "(A)")  "       c_fptr = c_funloc (" &
            // char (prefix) // feature // ")"
     end subroutine write_case
   end subroutine prclib_driver_write_module
 
 @ %def prclib_driver_write_module
 @ This function provides the overall library MD5sum.  The function is for
 internal use (therefore not bind(C)), the external interface is via the
 [[get_md5sum_ptr]] procedure with index 0.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_lib_md5sum_fun => prclib_driver_write_lib_md5sum_fun
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_write_lib_md5sum_fun (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! The MD5 sum of the library"
     write (unit, "(A)")  "function " // char (prefix) &
          // "md5sum () result (md5sum)"
     write (unit, "(A)")  "  implicit none"
     write (unit, "(A)")  "  character(32) :: md5sum"
     write (unit, "(A)")  "  md5sum = '" // driver%md5sum // "'"
     write (unit, "(A)")  "end function " // char (prefix) // "md5sum"
   end subroutine prclib_driver_write_lib_md5sum_fun
 
 @ %def prclib_driver_write_lib_md5sum_fun
 @
 \subsection{Interface bodies for informational functions}
 These interfaces implement the communication between WHIZARD (the main
 program) and the process-library driver.  The procedures are all
 BIND(C), so they can safely be exposed by the library and handled by
 the [[dlopen]] mechanism, which apparently understands only C calling
 conventions.
 
 In the sections below, for each procedure, we provide both the
 interface itself and a procedure that writes the correponding
 procedure as source code to the process library driver.
 
 \subsubsection{Process count}
 Return the number of processes contained in the library.
 <<Prclib interfaces: public>>=
   public :: prc_get_n_processes
 <<Prclib interfaces: interfaces>>=
   abstract interface
      function prc_get_n_processes () result (n) bind(C)
        import
        integer(c_int) :: n
      end function prc_get_n_processes
   end interface
 @ %def prc_get_n_processes
 @ Here is the code.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_get_n_processes_fun
 <<Prclib interfaces: procedures>>=
   subroutine write_get_n_processes_fun (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Return the number of processes in this library"
     write (unit, "(A)")  "function " // char (prefix) &
          // "get_n_processes () result (n) bind(C)"
     write (unit, "(A)")  "  use iso_c_binding"
     write (unit, "(A)")  "  implicit none"
     write (unit, "(A)")  "  integer(c_int) :: n"
     write (unit, "(A,I0)")  "  n = ", driver%n_processes
     write (unit, "(A)")  "end function " // char (prefix) &
          // "get_n_processes"
   end subroutine write_get_n_processes_fun
 
 @ %def write_get_n_processes_fun
 @
 \subsubsection{Informational string functions}
 These functions return constant information about the matrix-element
 code.
 
 The following procedures have to return strings.  With the BIND(C)
 constraint, we choose to return the C pointer to a string, and its
 length, so the procedures implement this interface.  They are actually
 subroutines.
 <<Prclib interfaces: public>>=
   public :: prc_get_stringptr
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine prc_get_stringptr (i, cptr, len) bind(C)
        import
        integer(c_int), intent(in) :: i
        type(c_ptr), intent(out) :: cptr
        integer(c_int), intent(out) :: len
      end subroutine prc_get_stringptr
   end interface
 @ %def prc_get_stringptr
 @ To hide this complication, we introduce a subroutine that converts the
 returned C pointer to a [[string_t]] object.  As a side effect, we
 deallocate the original after conversion -- otherwise, we might have a
 memory leak.
 
 For the conversion, we first pointer-convert the C pointer to a
 Fortran character array pointer, length 1 and size [[len]].  Using
 argument association and an internal subroutine, we convert this to a
 character array with length [[len]] and size 1.  Using ordinary
 assignment, we finally convert this to [[string_t]].
 
 The function takes the pointer-returning function as an argument.  The
 index [[i]] identifies the process in the library.
 <<Prclib interfaces: procedures>>=
   subroutine get_string_via_cptr (string, i, get_stringptr)
     type(string_t), intent(out) :: string
     integer, intent(in) :: i
     procedure(prc_get_stringptr) :: get_stringptr
     type(c_ptr) :: cptr
     integer(c_int) :: pid, len
     character(kind=c_char), dimension(:), pointer :: c_array
     pid = i
     call get_stringptr (pid, cptr, len)
     if (c_associated (cptr)) then
        call c_f_pointer (cptr, c_array, shape = [len])
        call set_string (c_array)
        call get_stringptr (0_c_int, cptr, len)
     else
        string = ""
     end if
   contains
     subroutine set_string (buffer)
       character(len, kind=c_char), dimension(1), intent(in) :: buffer
       string = buffer(1)
     end subroutine set_string
   end subroutine get_string_via_cptr
 
 @ %def get_string_via_cptr
 @ Since the module procedures return Fortran strings, we have to
 convert them.  This is the necessary auxiliary routine.  The routine
 is not BIND(C), it is not accessed from outside.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure, nopass :: write_string_to_array_fun
 <<Prclib interfaces: procedures>>=
   subroutine write_string_to_array_fun (unit, prefix)
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Auxiliary: convert character string &
          &to array pointer"
     write (unit, "(A)")  "subroutine " // char (prefix) &
          // "string_to_array (string, a)"
     write (unit, "(A)")  "  use iso_c_binding"
     write (unit, "(A)")  "  implicit none"
     write (unit, "(A)")  "  character(*), intent(in) :: string"
     write (unit, "(A)")  "  character(kind=c_char), dimension(:), &
          &allocatable, intent(out) :: a"
     write (unit, "(A)")  "  integer :: i"
     write (unit, "(A)")  "  allocate (a (len (string)))"
     write (unit, "(A)")  "  do i = 1, size (a)"
     write (unit, "(A)")  "     a(i) = string(i:i)"
     write (unit, "(A)")  "  end do"
     write (unit, "(A)")  "end subroutine " // char (prefix) &
          // "string_to_array"
   end subroutine write_string_to_array_fun
 
 @ %def write_string_to_array_fun
 @ The above routine is called by other functions.  It is not in a
 module, so they need its interface explicitly.
 <<Prclib interfaces: procedures>>=
   subroutine write_string_to_array_interface (unit, prefix)
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     write (unit, "(2x,A)")  "interface"
     write (unit, "(2x,A)")  "   subroutine " // char (prefix) &
          // "string_to_array (string, a)"
     write (unit, "(2x,A)")  "     use iso_c_binding"
     write (unit, "(2x,A)")  "     implicit none"
     write (unit, "(2x,A)")  "     character(*), intent(in) :: string"
     write (unit, "(2x,A)")  "     character(kind=c_char), dimension(:), &
          &allocatable, intent(out) :: a"
     write (unit, "(2x,A)")  "   end subroutine " // char (prefix) &
          // "string_to_array"
     write (unit, "(2x,A)")  "end interface"
   end subroutine write_string_to_array_interface
 
 @ %def write_string_to_array_interface
 @
 Here are the info functions which return strings, implementing the interface
 [[prc_get_stringptr]].
 
 Return the process ID for each process.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_get_process_id_fun
 <<Prclib interfaces: procedures>>=
   subroutine write_get_process_id_fun (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     integer :: i
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Return the process ID of process #i &
          &(as a C pointer to a character array)"
     write (unit, "(A)")  "subroutine " // char (prefix) &
          // "get_process_id_ptr (i, cptr, len) bind(C)"
     write (unit, "(A)")  "  use iso_c_binding"
     write (unit, "(A)")  "  implicit none"
     write (unit, "(A)")  "  integer(c_int), intent(in) :: i"
     write (unit, "(A)")  "  type(c_ptr), intent(out) :: cptr"
     write (unit, "(A)")  "  integer(c_int), intent(out) :: len"
     write (unit, "(A)")  "  character(kind=c_char), dimension(:), &
          &allocatable, target, save :: a"
     call write_string_to_array_interface (unit, prefix)
     write (unit, "(A)")  "  select case (i)"
     write (unit, "(A)")  "  case (0);  if (allocated (a))  deallocate (a)"
     do i = 1, driver%n_processes
        write (unit, "(A,I0,9A)")  "  case (", i, ");  ", &
             "call ", char (prefix), "string_to_array ('", &
             char (driver%record(i)%id), "', a)"
     end do
     write (unit, "(A)")  "  end select"
     write (unit, "(A)")  "  if (allocated (a)) then"
     write (unit, "(A)")  "     cptr = c_loc (a)"
     write (unit, "(A)")  "     len = size (a)"
     write (unit, "(A)")  "  else"
     write (unit, "(A)")  "     cptr = c_null_ptr"
     write (unit, "(A)")  "     len = 0"
     write (unit, "(A)")  "  end if"
     write (unit, "(A)")  "end subroutine " // char (prefix) &
          // "get_process_id_ptr"
   end subroutine write_get_process_id_fun
 
 @ %def write_get_process_id_fun
 @ Return the model name, given explicitly.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_get_model_name_fun
 <<Prclib interfaces: procedures>>=
   subroutine write_get_model_name_fun (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     integer :: i
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Return the model name for process #i &
          &(as a C pointer to a character array)"
     write (unit, "(A)")  "subroutine " // char (prefix) &
          // "get_model_name_ptr (i, cptr, len) bind(C)"
     write (unit, "(A)")  "  use iso_c_binding"
     write (unit, "(A)")  "  implicit none"
     write (unit, "(A)")  "  integer(c_int), intent(in) :: i"
     write (unit, "(A)")  "  type(c_ptr), intent(out) :: cptr"
     write (unit, "(A)")  "  integer(c_int), intent(out) :: len"
     write (unit, "(A)")  "  character(kind=c_char), dimension(:), &
          &allocatable, target, save :: a"
     call write_string_to_array_interface (unit, prefix)
     write (unit, "(A)")  "  select case (i)"
     write (unit, "(A)")  "  case (0);  if (allocated (a))  deallocate (a)"
     do i = 1, driver%n_processes
        write (unit, "(A,I0,9A)")  "  case (", i, ");  ", &
             "call ", char (prefix), "string_to_array ('" , &
             char (driver%record(i)%model_name), &
             "', a)"
     end do
     write (unit, "(A)")  "  end select"
     write (unit, "(A)")  "  if (allocated (a)) then"
     write (unit, "(A)")  "     cptr = c_loc (a)"
     write (unit, "(A)")  "     len = size (a)"
     write (unit, "(A)")  "  else"
     write (unit, "(A)")  "     cptr = c_null_ptr"
     write (unit, "(A)")  "     len = 0"
     write (unit, "(A)")  "  end if"
     write (unit, "(A)")  "end subroutine " // char (prefix) &
          // "get_model_name_ptr"
   end subroutine write_get_model_name_fun
 
 @ %def write_get_model_name_fun
 @ Call the MD5 sum function for the process.  The function calls the
 corresponding function of the matrix-element code, and it returns the
 C address of a character array with length 32.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_get_md5sum_fun
 <<Prclib interfaces: procedures>>=
   subroutine write_get_md5sum_fun (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     integer :: i
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Return the MD5 sum for the process configuration &
          &(as a C pointer to a character array)"
     write (unit, "(A)")  "subroutine " // char (prefix) &
          // "get_md5sum_ptr (i, cptr, len) bind(C)"
     write (unit, "(A)")  "  use iso_c_binding"
     call driver%write_interfaces (unit, var_str ("md5sum"))
     write (unit, "(A)")  "  interface"
     write (unit, "(A)")  "     function " // char (prefix) &
          // "md5sum () result (md5sum)"
     write (unit, "(A)")  "       character(32) :: md5sum"
     write (unit, "(A)")  "     end function " // char (prefix) // "md5sum"
     write (unit, "(A)")  "  end interface"
     write (unit, "(A)")  "  integer(c_int), intent(in) :: i"
     write (unit, "(A)")  "  type(c_ptr), intent(out) :: cptr"
     write (unit, "(A)")  "  integer(c_int), intent(out) :: len"
     write (unit, "(A)")  "  character(kind=c_char), dimension(32), &
          &target, save :: md5sum"
     write (unit, "(A)")  "  select case (i)"
     write (unit, "(A)")  "  case (0)"
     write (unit, "(A)")  "     call copy (" // char (prefix) // "md5sum ())"
     write (unit, "(A)")  "     cptr = c_loc (md5sum)"
     do i = 1, driver%n_processes
        write (unit, "(A,I0,A)")  "  case (", i, ")"
        call driver%record(i)%write_md5sum_call (unit)
     end do
     write (unit, "(A)")  "  case default"
     write (unit, "(A)")  "     cptr = c_null_ptr"
     write (unit, "(A)")  "  end select"
     write (unit, "(A)")  "  len = 32"
     write (unit, "(A)")  "contains"
     write (unit, "(A)")  "  subroutine copy (md5sum_tmp)"
     write (unit, "(A)")  "    character, dimension(32), intent(in) :: &
          &md5sum_tmp"
     write (unit, "(A)")  "    md5sum = md5sum_tmp"
     write (unit, "(A)")  "  end subroutine copy"
     write (unit, "(A)")  "end subroutine " // char (prefix) &
            // "get_md5sum_ptr"
   end subroutine write_get_md5sum_fun
 
 @ %def write_get_md5sum_fun
 @ The actual call depends on the type of matrix element.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_md5sum_call => prclib_driver_record_write_md5sum_call
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_md5sum_call (record, unit)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     call record%writer%write_md5sum_call (unit, record%id)
   end subroutine prclib_driver_record_write_md5sum_call
 
 @ %def prclib_driver_record_write_md5sum_call
 @ The interface goes into the writer base type:
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(write_code), deferred :: write_md5sum_call
 @ %def write_md5sum_call
 @ In the Fortran module case, we take a detour.  The string returned
 by the Fortran function is copied into a fixed-size array.  The copy
 routine is an internal subroutine of [[get_md5sum_ptr]].  We
 return the C address of the target array.
 <<Prclib interfaces: prc writer f module: TBP>>=
   procedure :: write_md5sum_call => prc_writer_f_module_write_md5sum_call
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_f_module_write_md5sum_call (writer, unit, id)
     class(prc_writer_f_module_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(5x,9A)")  "call copy (", &
          char (writer%get_c_procname (id, var_str ("md5sum"))), " ())"
     write (unit, "(5x,9A)")  "cptr = c_loc (md5sum)"
   end subroutine prc_writer_f_module_write_md5sum_call
 
 @ %def prc_writer_f_module_write_md5sum_call
 @ In the C library case, the library function returns a C pointer,
 which we can just copy.
 <<Prclib interfaces: prc writer c lib: TBP>>=
   procedure :: write_md5sum_call => prc_writer_c_lib_write_md5sum_call
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_c_lib_write_md5sum_call (writer, unit, id)
     class(prc_writer_c_lib_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(5x,9A)") &
          "cptr =  ", &
          char (writer%get_c_procname (id, var_str ("get_md5sum"))), " ()"
   end subroutine prc_writer_c_lib_write_md5sum_call
 
 @ %def prc_writer_c_lib_write_md5sum_call
 @
 \subsubsection{Actual references to the info functions}
 The string-valued info functions return C character arrays.  For the
 API of the library driver, we provide convenience functions which
 (re)convert those arrays into [[string_t]] objects.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: get_process_id => prclib_driver_get_process_id
   procedure :: get_model_name => prclib_driver_get_model_name
   procedure :: get_md5sum => prclib_driver_get_md5sum
 <<Prclib interfaces: procedures>>=
   function prclib_driver_get_process_id (driver, i) result (string)
     type(string_t) :: string
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     call get_string_via_cptr (string, i, driver%get_process_id_ptr)
   end function prclib_driver_get_process_id
 
   function prclib_driver_get_model_name (driver, i) result (string)
     type(string_t) :: string
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     call get_string_via_cptr (string, i, driver%get_model_name_ptr)
   end function prclib_driver_get_model_name
 
   function prclib_driver_get_md5sum (driver, i) result (string)
     type(string_t) :: string
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     call get_string_via_cptr (string, i, driver%get_md5sum_ptr)
   end function prclib_driver_get_md5sum
 
 @ %def prclib_driver_get_process_id
 @ %def prclib_driver_get_model_name
 @ %def prclib_driver_get_md5sum
 @
 \subsubsection{Informational logical functions}
 When returning a logical value, we use the C boolean type, which
 may differ from Fortran.
 <<Prclib interfaces: public>>=
   public :: prc_get_log
 <<Prclib interfaces: interfaces>>=
   abstract interface
      function prc_get_log (pid) result (l) bind(C)
        import
        integer(c_int), intent(in) :: pid
        logical(c_bool) :: l
      end function prc_get_log
   end interface
 @ %def prc_get_log
 @ Return a logical flag which tells whether OpenMP is supported for a
 specific process code.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_get_openmp_status_fun
 <<Prclib interfaces: procedures>>=
   subroutine write_get_openmp_status_fun (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     integer :: i
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Return the OpenMP support status"
     write (unit, "(A)")  "function " // char (prefix) &
          // "get_openmp_status (i) result (openmp_status) bind(C)"
     write (unit, "(A)")  "  use iso_c_binding"
     call driver%write_interfaces (unit, var_str ("openmp_supported"))
     write (unit, "(A)")  "  integer(c_int), intent(in) :: i"
     write (unit, "(A)")  "  logical(c_bool) :: openmp_status"
     write (unit, "(A)")  "  select case (i)"
     do i = 1, driver%n_processes
        write (unit, "(A,I0,9A)")  "  case (", i, ");  ", &
             "openmp_status = ", &
             char (driver%record(i)%get_c_procname &
             (var_str ("openmp_supported"))), " ()"
     end do
     write (unit, "(A)")  "  end select"
     write (unit, "(A)")  "end function " // char (prefix) &
          // "get_openmp_status"
   end subroutine write_get_openmp_status_fun
 
 @ %def write_get_openmp_status_fun
 @
 \subsubsection{Informational integer functions}
 Various process metadata are integer values.  We can use a single
 interface for all of them.
 <<Prclib interfaces: public>>=
   public :: prc_get_int
 <<Prclib interfaces: interfaces>>=
   abstract interface
      function prc_get_int (pid) result (n) bind(C)
        import
        integer(c_int), intent(in) :: pid
        integer(c_int) :: n
      end function prc_get_int
   end interface
 @ %def prc_get_int
 @ This function returns any data of type integer, for each process.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_get_int_fun
 <<Prclib interfaces: procedures>>=
   subroutine write_get_int_fun (driver, unit, prefix, feature)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     type(string_t), intent(in) :: feature
     integer :: i
     write (unit, "(A)")  ""
     write (unit, "(9A)")  "! Return the value of ", char (feature)
     write (unit, "(9A)")  "function ", char (prefix), &
          "get_", char (feature), " (pid)", &
          " result (", char (feature), ") bind(C)"
     write (unit, "(9A)")  "  use iso_c_binding"
     call driver%write_interfaces (unit, feature)
     write (unit, "(9A)")  "  integer(c_int), intent(in) :: pid"
     write (unit, "(9A)")  "  integer(c_int) :: ", char (feature)
     write (unit, "(9A)")  "  select case (pid)"
     do i = 1, driver%n_processes
        write (unit, "(2x,A,I0,9A)")  "case (", i, ");  ", &
             char (feature), " = ", &
             char (driver%record(i)%get_c_procname (feature)), &
             " ()"
     end do
     write (unit, "(9A)")  "  end select"
     write (unit, "(9A)")  "end function ", char (prefix), &
          "get_", char (feature)
   end subroutine write_get_int_fun
 
 @ %def write_get_int_fun
 @ Write a [[case]] line that assigns the value of the external function
 to the current return value.
 <<Prclib interfaces: procedures>>=
   subroutine write_case_int_fun (record, unit, i, feature)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     integer, intent(in) :: i
     type(string_t), intent(in) :: feature
     write (unit, "(5x,A,I0,9A)")  "case (", i, ");  ", &
          char (feature), " = ", char (record%get_c_procname (feature))
   end subroutine write_case_int_fun
 
 @ %def write_case_int_fun
 @
 \subsubsection{Flavor and helicity tables}
 Transferring tables is more complicated.  First, a two-dimensional array.
 <<Prclib interfaces: public>>=
   public :: prc_set_int_tab1
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine prc_set_int_tab1 (pid, tab, shape) bind(C)
        import
        integer(c_int), intent(in) :: pid
        integer(c_int), dimension(*), intent(out) :: tab
        integer(c_int), dimension(2), intent(in) :: shape
      end subroutine prc_set_int_tab1
   end interface
 @ %def prc_set_int_tab1
 @ This subroutine returns a table of integers.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_set_int_sub
 <<Prclib interfaces: procedures>>=
   subroutine write_set_int_sub (driver, unit, prefix, feature)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     type(string_t), intent(in) :: feature
     integer :: i
     write (unit, "(A)")  ""
     write (unit, "(9A)")  "! Set table: ", char (feature)
     write (unit, "(9A)")  "subroutine ", char (prefix), &
          "set_", char (feature), "_ptr (pid, ", char (feature), &
          ", shape) bind(C)"
     write (unit, "(9A)")  "  use iso_c_binding"
     call driver%write_interfaces (unit, feature)
     write (unit, "(9A)")  "  integer(c_int), intent(in) :: pid"
     write (unit, "(9A)")  "  integer(c_int), dimension(*), intent(out) :: ", &
          char (feature)
     write (unit, "(9A)")  "  integer(c_int), dimension(2), intent(in) :: shape"
     write (unit, "(9A)")  "  integer, dimension(:,:), allocatable :: ", &
          char (feature), "_tmp"
     write (unit, "(9A)")  "  integer :: i, j"
     write (unit, "(9A)")  "  select case (pid)"
     do i = 1, driver%n_processes
        write (unit, "(2x,A,I0,A)")  "case (", i, ")"
        call driver%record(i)%write_int_sub_call (unit, feature)
     end do
     write (unit, "(9A)")  "  end select"
     write (unit, "(9A)")  "end subroutine ", char (prefix), &
          "set_", char (feature), "_ptr"
   end subroutine write_set_int_sub
 
 @ %def write_set_int_sub
 @ The actual call depends on the type of matrix element.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_int_sub_call => prclib_driver_record_write_int_sub_call
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_int_sub_call (record, unit, feature)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     type(string_t), intent(in) :: feature
     call record%writer%write_int_sub_call (unit, record%id, feature)
   end subroutine prclib_driver_record_write_int_sub_call
 
 @ %def prclib_driver_record_write_int_sub_call
 @ The interface goes into the writer base type:
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(write_feature_code), deferred :: write_int_sub_call
 @ %def write_int_sub_call
 @ In the Fortran module case, we need an extra copy in the
 (academical) situation where default integer and [[c_int]] differ.
 Otherwise, we just associate a Fortran array with the C pointer and
 let the matrix-element subroutine fill the array.
 <<Prclib interfaces: prc writer f module: TBP>>=
   procedure :: write_int_sub_call => prc_writer_f_module_write_int_sub_call
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_f_module_write_int_sub_call (writer, unit, id, feature)
     class(prc_writer_f_module_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     write (unit, "(5x,9A)")  "allocate (",  char (feature), "_tmp ", &
          "(shape(1), shape(2)))"
     write (unit, "(5x,9A)")  "call ", &
          char (writer%get_c_procname (id, feature)), &
          " (", char (feature), "_tmp)"
     write (unit, "(5x,9A)")  "forall (i=1:shape(1), j=1:shape(2)) "
     write (unit, "(8x,9A)")  char (feature), "(i + shape(1)*(j-1)) = ", &
          char (feature), "_tmp", "(i,j)"
     write (unit, "(5x,9A)")  "end forall"
   end subroutine prc_writer_f_module_write_int_sub_call
 
 @ %def prc_writer_f_module_write_int_sub_call
 @ In the C library case, we just transfer the C pointer to the library
 function.
 <<Prclib interfaces: prc writer c lib: TBP>>=
   procedure :: write_int_sub_call => prc_writer_c_lib_write_int_sub_call
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_c_lib_write_int_sub_call (writer, unit, id, feature)
     class(prc_writer_c_lib_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     write (unit, "(5x,9A)")  "call ", &
          char (writer%get_c_procname (id, feature)), " (", char (feature), ")"
   end subroutine prc_writer_c_lib_write_int_sub_call
 
 @ %def prc_writer_c_lib_write_int_sub_call
 @
 \subsubsection{Color state table}
 The color-state specification needs a table of integers (one array per
 color flow) and a corresponding array of color-ghost flags.
 <<Prclib interfaces: public>>=
   public :: prc_set_col_state
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine prc_set_col_state (pid, col_state, ghost_flag, shape) bind(C)
        import
        integer(c_int), intent(in) :: pid
        integer(c_int), dimension(*), intent(out) :: col_state
        logical(c_bool), dimension(*), intent(out) :: ghost_flag
        integer(c_int), dimension(3), intent(in) :: shape
      end subroutine prc_set_col_state
   end interface
 @ %def prc_set_int_tab2
 @
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_set_col_state_sub
 <<Prclib interfaces: procedures>>=
   subroutine write_set_col_state_sub (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     integer :: i
     type(string_t) :: feature
     feature = "col_state"
     write (unit, "(A)")  ""
     write (unit, "(9A)")  "! Set tables: col_state, ghost_flag"
     write (unit, "(9A)")  "subroutine ", char (prefix), &
          "set_col_state_ptr (pid, col_state, ghost_flag, shape) bind(C)"
     write (unit, "(9A)")  "  use iso_c_binding"
     call driver%write_interfaces (unit, feature)
     write (unit, "(9A)")  "  integer(c_int), intent(in) :: pid"
     write (unit, "(9A)") &
          "  integer(c_int), dimension(*), intent(out) :: col_state"
     write (unit, "(9A)") &
          "  logical(c_bool), dimension(*), intent(out) :: ghost_flag"
     write (unit, "(9A)") &
          "  integer(c_int), dimension(3), intent(in) :: shape"
     write (unit, "(9A)") &
          "  integer, dimension(:,:,:), allocatable :: col_state_tmp"
     write (unit, "(9A)") &
          "  logical, dimension(:,:), allocatable :: ghost_flag_tmp"
     write (unit, "(9A)") "  integer :: i, j, k"
     write (unit, "(A)")  "  select case (pid)"
     do i = 1, driver%n_processes
        write (unit, "(A,I0,A)")  "  case (", i, ")"
        call driver%record(i)%write_col_state_call (unit)
     end do
     write (unit, "(A)")  "  end select"
     write (unit, "(9A)")  "end subroutine ", char (prefix), &
          "set_col_state_ptr"
   end subroutine write_set_col_state_sub
 
 @ %def write_set_col_state_sub
 @ The actual call depends on the type of matrix element.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_col_state_call => prclib_driver_record_write_col_state_call
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_col_state_call (record, unit)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     call record%writer%write_col_state_call (unit, record%id)
   end subroutine prclib_driver_record_write_col_state_call
 
 @ %def prclib_driver_record_write_col_state_call
 @ The interface goes into the writer base type:
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(write_code), deferred :: write_col_state_call
 @ %def write_col_state_call
 @ In the Fortran module case, we need an extra copy in the
 (academical) situation where default integer and [[c_int]] differ.
 Otherwise, we just associate a Fortran array with the C pointer and
 let the matrix-element subroutine fill the array.
 <<Prclib interfaces: prc writer f module: TBP>>=
   procedure :: write_col_state_call => prc_writer_f_module_write_col_state_call
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_f_module_write_col_state_call (writer, unit, id)
     class(prc_writer_f_module_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(9A)")  "  allocate (col_state_tmp ", &
             "(shape(1), shape(2), shape(3)))"
     write (unit, "(5x,9A)")  "allocate (ghost_flag_tmp ", &
                "(shape(2), shape(3)))"
     write (unit, "(5x,9A)")  "call ", &
          char (writer%get_c_procname (id, var_str ("col_state"))), &
          " (col_state_tmp, ghost_flag_tmp)"
     write (unit, "(5x,9A)")  "forall (i = 1:shape(2), j = 1:shape(3))"
     write (unit, "(8x,9A)")  "forall (k = 1:shape(1))"
     write (unit, "(11x,9A)")  &
          "col_state(k + shape(1) * (i + shape(2)*(j-1) - 1)) ", &
          "= col_state_tmp(k,i,j)"
     write (unit, "(8x,9A)")  "end forall"
     write (unit, "(8x,9A)")  &
          "ghost_flag(i + shape(2)*(j-1)) = ghost_flag_tmp(i,j)"
     write (unit, "(5x,9A)")  "end forall"
   end subroutine prc_writer_f_module_write_col_state_call
 
 @ %def prc_writer_f_module_write_col_state_call
 @ In the C library case, we just transfer the C pointer to the library
 function.
 <<Prclib interfaces: prc writer c lib: TBP>>=
   procedure :: write_col_state_call => prc_writer_c_lib_write_col_state_call
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_c_lib_write_col_state_call (writer, unit, id)
     class(prc_writer_c_lib_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(5x,9A)")  "call ", &
          char (writer%get_c_procname (id, var_str ("col_state"))), &
          " (col_state, ghost_flag)"
   end subroutine prc_writer_c_lib_write_col_state_call
 
 @ %def prc_writer_c_lib_write_col_state_call
 @
 \subsubsection{Color factors}
 For the color-factor information, we return two integer arrays and a
 complex array.
 <<Prclib interfaces: public>>=
   public :: prc_set_color_factors
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine prc_set_color_factors &
           (pid, cf_index1, cf_index2, color_factors, shape) bind(C)
        import
        integer(c_int), intent(in) :: pid
        integer(c_int), dimension(*), intent(out) :: cf_index1, cf_index2
        complex(c_default_complex), dimension(*), intent(out) :: color_factors
        integer(c_int), dimension(1), intent(in) :: shape
      end subroutine prc_set_color_factors
   end interface
 
 @ %def prc_set_color_factors
 @ This subroutine returns the color-flavor factor table.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_set_color_factors_sub
 <<Prclib interfaces: procedures>>=
   subroutine write_set_color_factors_sub (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     integer :: i
     type(string_t) :: feature
     feature = "color_factors"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Set tables: color factors"
     write (unit, "(9A)")  "subroutine ", char (prefix), &
          "set_color_factors_ptr (pid, cf_index1, cf_index2, color_factors, ", &
          "shape) bind(C)"
     write (unit, "(A)")  "  use iso_c_binding"
     write (unit, "(A)")  "  use kinds"
     write (unit, "(A)")  "  use omega_color"
     call driver%write_interfaces (unit, feature)
     write (unit, "(A)")  "  integer(c_int), intent(in) :: pid"
     write (unit, "(A)")  "  integer(c_int), dimension(1), intent(in) :: shape"
     write (unit, "(A)")  "  integer(c_int), dimension(*), intent(out) :: &
          &cf_index1, cf_index2"
     write (unit, "(A)")  "  complex(c_default_complex), dimension(*), &
          &intent(out) :: color_factors"
     write (unit, "(A)")  "  type(omega_color_factor), dimension(:), &
          &allocatable :: cf"
     write (unit, "(A)")  "  select case (pid)"
     do i = 1, driver%n_processes
        write (unit, "(2x,A,I0,A)")  "case (", i, ")"
        call driver%record(i)%write_color_factors_call (unit)
     end do
     write (unit, "(A)")  "  end select"
     write (unit, "(A)")  "end subroutine " // char (prefix) &
          // "set_color_factors_ptr"
   end subroutine write_set_color_factors_sub
 
 @ %def write_set_color_factors_sub
 @ The actual call depends on the type of matrix element.
 <<Prclib interfaces: prclib driver record: TBP>>=
   procedure :: write_color_factors_call => prclib_driver_record_write_color_factors_call
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_record_write_color_factors_call (record, unit)
     class(prclib_driver_record_t), intent(in) :: record
     integer, intent(in) :: unit
     call record%writer%write_color_factors_call (unit, record%id)
   end subroutine prclib_driver_record_write_color_factors_call
 
 @ %def prclib_driver_record_write_color_factors_call
 @ The interface goes into the writer base type:
 <<Prclib interfaces: prc writer: TBP>>=
   procedure(write_code), deferred :: write_color_factors_call
 @ %def write_color_factors_call
 @ In the Fortran module case, the matrix-element procedure fills an
 array of [[omega_color_factor]] elements.  We distribute this array
 among two integer arrays and one complex-valued array, for which we
 have the C pointers.
 <<Prclib interfaces: prc writer f module: TBP>>=
   procedure :: write_color_factors_call => prc_writer_f_module_write_color_factors_call
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_f_module_write_color_factors_call (writer, unit, id)
     class(prc_writer_f_module_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(5x,A)")  "allocate (cf (shape(1)))"
     write (unit, "(5x,9A)")  "call ", &
          char (writer%get_c_procname (id, var_str ("color_factors"))), " (cf)"
     write (unit, "(5x,9A)")  "cf_index1(1:shape(1)) = cf%i1"
     write (unit, "(5x,9A)")  "cf_index2(1:shape(1)) = cf%i2"
     write (unit, "(5x,9A)")  "color_factors(1:shape(1)) = cf%factor"
   end subroutine prc_writer_f_module_write_color_factors_call
 
 @ %def prc_writer_f_module_write_color_factors_call
 @ In the C library case, we just transfer the C pointers to the library
 function.  There are three arrays.
 <<Prclib interfaces: prc writer c lib: TBP>>=
   procedure :: write_color_factors_call => &
        prc_writer_c_lib_write_color_factors_call
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_c_lib_write_color_factors_call (writer, unit, id)
     class(prc_writer_c_lib_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(5x,9A)")  "call ", &
          char (writer%get_c_procname (id, var_str ("color_factors"))), &
          " (cf_index1, cf_index2, color_factors)"
   end subroutine prc_writer_c_lib_write_color_factors_call
 
 @ %def prc_writer_c_lib_write_color_factors_call
 @
 \subsection{Interfaces for C-library matrix element}
 If the matrix element code is not provided as a Fortran module but as
 a C or bind(C) Fortran library, we need explicit interfaces for the
 library functions.  They are not identical to the Fortran module
 versions.  They transfer pointers directly.
 
 The implementation is part of the [[prc_writer_c_lib]] type, which
 serves as base type for all C-library writers.  It writes specific
 interfaces depending on the feature.
 
 We bind this as the method [[write_standard_interface]] instead of
 [[write_interface]], because we have to override the latter.
 Otherwise we could not call the method because the writer type is
 abstract.
 <<Prclib interfaces: prc writer c lib: TBP>>=
   procedure :: write_standard_interface => prc_writer_c_lib_write_interface
 <<Prclib interfaces: procedures>>=
   subroutine prc_writer_c_lib_write_interface (writer, unit, id, feature)
     class(prc_writer_c_lib_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     select case (char (feature))
     case ("md5sum")
        write (unit, "(2x,9A)")  "interface"
        write (unit, "(5x,9A)")  "function ", &
             char (writer%get_c_procname (id, var_str ("get_md5sum"))), &
             " () result (cptr) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "implicit none"
        write (unit, "(7x,9A)")  "type(c_ptr) :: cptr"
        write (unit, "(5x,9A)")  "end function ", &
             char (writer%get_c_procname (id, var_str ("get_md5sum")))
        write (unit, "(2x,9A)")  "end interface"
     case ("openmp_supported")
        write (unit, "(2x,9A)")  "interface"
        write (unit, "(5x,9A)")  "function ", &
             char (writer%get_c_procname (id, feature)), &
             " () result (status) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "implicit none"
        write (unit, "(7x,9A)")  "logical(c_bool) :: status"
        write (unit, "(5x,9A)")  "end function ", &
             char (writer%get_c_procname (id, feature))
        write (unit, "(2x,9A)")  "end interface"
     case ("n_in", "n_out", "n_flv", "n_hel", "n_col", "n_cin", "n_cf")
        write (unit, "(2x,9A)")  "interface"
        write (unit, "(5x,9A)")  "function ", &
             char (writer%get_c_procname (id, feature)), &
             " () result (n) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "implicit none"
        write (unit, "(7x,9A)")  "integer(c_int) :: n"
        write (unit, "(5x,9A)")  "end function ", &
             char (writer%get_c_procname (id, feature))
        write (unit, "(2x,9A)")  "end interface"
     case ("flv_state", "hel_state")
        write (unit, "(2x,9A)")  "interface"
        write (unit, "(5x,9A)")  "subroutine ", &
             char (writer%get_c_procname (id, feature)), &
             " (", char (feature), ") bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "implicit none"
        write (unit, "(7x,9A)")  "integer(c_int), dimension(*), intent(out) ", &
             ":: ", char (feature)
        write (unit, "(5x,9A)")  "end subroutine ", &
             char (writer%get_c_procname (id, feature))
        write (unit, "(2x,9A)")  "end interface"
     case ("col_state")
        write (unit, "(2x,9A)")  "interface"
        write (unit, "(5x,9A)")  "subroutine ", &
             char (writer%get_c_procname (id, feature)), &
             " (col_state, ghost_flag) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "implicit none"
        write (unit, "(7x,9A)")  "integer(c_int), dimension(*), intent(out) ", &
             ":: col_state"
        write (unit, "(7x,9A)")  "logical(c_bool), dimension(*), intent(out) ", &
             ":: ghost_flag"
        write (unit, "(5x,9A)")  "end subroutine ", &
             char (writer%get_c_procname (id, feature))
        write (unit, "(2x,9A)")  "end interface"
     case ("color_factors")
        write (unit, "(2x,9A)")  "interface"
        write (unit, "(5x,9A)")  "subroutine ", &
             char (writer%get_c_procname (id, feature)), &
             " (cf_index1, cf_index2, color_factors) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "implicit none"
        write (unit, "(7x,9A)")  "integer(c_int), dimension(*), &
             &intent(out) :: cf_index1"
        write (unit, "(7x,9A)")  "integer(c_int), dimension(*), &
             &intent(out) :: cf_index2"
        write (unit, "(7x,9A)")  "complex(c_default_complex), dimension(*), &
             &intent(out) :: color_factors"
        write (unit, "(5x,9A)")  "end subroutine ", &
             char (writer%get_c_procname (id, feature))
        write (unit, "(2x,9A)")  "end interface"
     end select
   end subroutine prc_writer_c_lib_write_interface
 
 @ %def prc_writer_c_lib_write_interface
 @
 \subsection{Retrieving the tables}
 In the previous section we had the writer routines for procedures that
 return tables, actually C pointers to tables.  Here, we write
 convenience routines that unpack them and move the contents to
 suitable Fortran arrays.
 
 The flavor and helicity tables are two-dimensional integer arrays.  We
 use intermediate storage for correctly transforming C to Fortran data
 types.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: set_flv_state => prclib_driver_set_flv_state
   procedure :: set_hel_state => prclib_driver_set_hel_state
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_set_flv_state (driver, i, flv_state)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     integer, dimension(:,:), allocatable, intent(out) :: flv_state
     integer :: n_tot, n_flv
     integer(c_int) :: pid
     integer(c_int), dimension(:,:), allocatable :: c_flv_state
     pid = i
     n_tot = driver%get_n_in (pid) + driver%get_n_out (pid)
     n_flv = driver%get_n_flv (pid)
     allocate (flv_state (n_tot, n_flv))
     allocate (c_flv_state (n_tot, n_flv))
     call driver%set_flv_state_ptr &
          (pid, c_flv_state, int ([n_tot, n_flv], kind=c_int))
     flv_state = c_flv_state
   end subroutine prclib_driver_set_flv_state
 
   subroutine prclib_driver_set_hel_state (driver, i, hel_state)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     integer, dimension(:,:), allocatable, intent(out) :: hel_state
     integer :: n_tot, n_hel
     integer(c_int) :: pid
     integer(c_int), dimension(:,:), allocatable, target :: c_hel_state
     pid = i
     n_tot = driver%get_n_in (pid) + driver%get_n_out (pid)
     n_hel = driver%get_n_hel (pid)
     allocate (hel_state (n_tot, n_hel))
     allocate (c_hel_state (n_tot, n_hel))
     call driver%set_hel_state_ptr &
          (pid, c_hel_state, int ([n_tot, n_hel], kind=c_int))
     hel_state = c_hel_state
   end subroutine prclib_driver_set_hel_state
 
 @ %def prclib_driver_set_flv_state
 @ %def prclib_driver_set_hel_state
 @ The color-flow table is three-dimensional, otherwise similar.  We
 simultaneously set the ghost-flag table, which consists of logical
 entries.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: set_col_state => prclib_driver_set_col_state
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_set_col_state (driver, i, col_state, ghost_flag)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     integer, dimension(:,:,:), allocatable, intent(out) :: col_state
     logical, dimension(:,:), allocatable, intent(out) :: ghost_flag
     integer :: n_cin, n_tot, n_col
     integer(c_int) :: pid
     integer(c_int), dimension(:,:,:), allocatable :: c_col_state
     logical(c_bool), dimension(:,:), allocatable :: c_ghost_flag
     pid = i
     n_cin = driver%get_n_cin (pid)
     n_tot = driver%get_n_in (pid) + driver%get_n_out (pid)
     n_col = driver%get_n_col (pid)
     allocate (col_state (n_cin, n_tot, n_col))
     allocate (c_col_state (n_cin, n_tot, n_col))
     allocate (ghost_flag (n_tot, n_col))
     allocate (c_ghost_flag (n_tot, n_col))
     call driver%set_col_state_ptr (pid, &
          c_col_state, c_ghost_flag, int ([n_cin, n_tot, n_col], kind=c_int))
     col_state = c_col_state
     ghost_flag = c_ghost_flag
   end subroutine prclib_driver_set_col_state
 
 @ %def prclib_driver_set_col_state
 @ The color-factor table is a sparse matrix: a two-column array of indices and
 one array which contains the corresponding factors.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: set_color_factors => prclib_driver_set_color_factors
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_set_color_factors (driver, i, color_factors, cf_index)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     complex(default), dimension(:), allocatable, intent(out) :: color_factors
     integer, dimension(:,:), allocatable, intent(out) :: cf_index
     integer :: n_cf
     integer(c_int) :: pid
     complex(c_default_complex), dimension(:), allocatable, target :: c_color_factors
     integer(c_int), dimension(:), allocatable, target :: c_cf_index1
     integer(c_int), dimension(:), allocatable, target :: c_cf_index2
     pid = i
     n_cf = driver%get_n_cf (pid)
     allocate (color_factors (n_cf))
     allocate (c_color_factors (n_cf))
     allocate (c_cf_index1 (n_cf))
     allocate (c_cf_index2 (n_cf))
     call driver%set_color_factors_ptr (pid, &
          c_cf_index1, c_cf_index2, &
          c_color_factors, int ([n_cf], kind=c_int))
     color_factors = c_color_factors
     allocate (cf_index (2, n_cf))
     cf_index(1,:) = c_cf_index1
     cf_index(2,:) = c_cf_index2
   end subroutine prclib_driver_set_color_factors
 
 @ %def prclib_driver_set_color_factors
 @
 \subsection{Returning a procedure pointer}
 The functions that directly access the matrix element, event by event,
 are assigned to a process-specific driver object as procedure
 pointers.  For the [[dlopen]] interface, we use C function pointers.
 This subroutine returns such a pointer:
 <<Prclib interfaces: public>>=
   public :: prc_get_fptr
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine prc_get_fptr (pid, fid, fptr) bind(C)
        import
        integer(c_int), intent(in) :: pid
        integer(c_int), intent(in) :: fid
        type(c_funptr), intent(out) :: fptr
      end subroutine prc_get_fptr
   end interface
 
 @ %def prc_get_fptr
 @ This procedure writes the source code for the procedure pointer
 returning subroutine.
 
 All C functions that are provided by the matrix element code of a
 specific process are handled here.  The selection consists of a double
 layered [[select]] [[case]] construct.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: write_get_fptr_sub
 <<Prclib interfaces: procedures>>=
   subroutine write_get_fptr_sub (driver, unit, prefix)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: unit
     type(string_t), intent(in) :: prefix
     integer :: i, j
     write (unit, "(A)")  ""
     write (unit, "(A)")  "! Return C pointer to a procedure:"
     write (unit, "(A)")  "! pid = process index;  fid = function index"
     write (unit, "(4A)")  "subroutine ", char (prefix), "get_fptr ", &
          "(pid, fid, fptr) bind(C)"
     write (unit, "(A)")  "  use iso_c_binding"
     write (unit, "(A)")  "  use kinds"
     write (unit, "(A)")  "  implicit none"
     write (unit, "(A)")  "  integer(c_int), intent(in) :: pid"
     write (unit, "(A)")  "  integer(c_int), intent(in) :: fid"
     write (unit, "(A)")  "  type(c_funptr), intent(out) :: fptr"
     do i = 1, driver%n_processes
        call driver%record(i)%write_interfaces (unit)
     end do
     write (unit, "(A)")  "  select case (pid)"
     do i = 1, driver%n_processes
        write (unit, "(2x,A,I0,A)")  "case (", i, ")"
        write (unit, "(5x,A)")  "select case (fid)"
        associate (record => driver%record(i))
          do j = 1, size (record%feature)
             write (unit, "(5x,A,I0,9A)")  "case (", j, ");  ", &
                  "fptr = c_funloc (", &
                  char (record%get_c_procname (record%feature(j))), &
                  ")"
          end do
        end associate
        write (unit, "(5x,A)")  "end select"
     end do
     write (unit, "(A)")  "  end select"
     write (unit, "(3A)")  "end subroutine ", char (prefix), "get_fptr"
   end subroutine write_get_fptr_sub
 
 @ %def write_get_fptr_sub
 @ The procedures for which we want to return a pointer (the 'features'
 of the matrix element code) are actually Fortran module procedures.
 If we want to have a C signature, we must write wrapper functions for
 all of them.  The procedures, their signatures, and the appropriate
 writer routines are specific for the process type.
 
 To keep this generic, we do not provide the writer routines here, but
 just the interface for a writer routine.  The actual routines are
 stored in the process record.
 
 The [[prefix]] indicates the library, the [[id]] indicates the
 process, and [[procname]] is the bare name of the procedure to be
 written.
 <<Prclib interfaces: public>>=
   public :: write_driver_code
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine write_driver_code (unit, prefix, id, procname)
        import
        integer, intent(in) :: unit
        type(string_t), intent(in) :: prefix
        type(string_t), intent(in) :: id
        type(string_t), intent(in) :: procname
      end subroutine write_driver_code
   end interface
 
 @ %def write_driver_code
 @
 \subsection{Hooks}
 Interface for additional library unload / reload hooks (currently unused!)
 <<Prclib interfaces: public>>=
   public :: prclib_unload_hook
   public :: prclib_reload_hook
 <<Prclib interfaces: interfaces>>=
   abstract interface
      subroutine prclib_unload_hook (libname)
        import
        type(string_t), intent(in) :: libname
      end subroutine prclib_unload_hook
 
      subroutine prclib_reload_hook (libname)
        import
        type(string_t), intent(in) :: libname
      end subroutine prclib_reload_hook
   end interface
 @ %def prclib_unload_hook
 @ %def prclib_reload_hook
 @
 \subsection{Make source, compile, link}
 Since we should have written a Makefile, these tasks amount to simple
 [[make]] calls.  Note that the Makefile targets depend on each other,
 so calling [[link]] executes also the [[source]] and [[compile]]
 steps, when necessary.
 
 Optionally, we can use a subdirectory.  We construct a prefix for the
 subdirectory, and generate a shell [[cd]] call that moves us into the
 workspace.
 
 The [[prefix]] version is intended to be prepended to a filename, and can be
 empty.  The [[path]] version is intended to be prepended with a following
 slash, so the default is [[.]].
 <<Prclib interfaces: public>>=
   public :: workspace_prefix
   public :: workspace_path
 <<Prclib interfaces: procedures>>=
   function workspace_prefix (workspace) result (prefix)
     type(string_t), intent(in), optional :: workspace
     type(string_t) :: prefix
     if (present (workspace)) then
        if (workspace /= "") then
           prefix = workspace // "/"
        else
           prefix = ""
        end if
     else
        prefix = ""
     end if
   end function workspace_prefix
 
   function workspace_path (workspace) result (path)
     type(string_t), intent(in), optional :: workspace
     type(string_t) :: path
     if (present (workspace)) then
        if (workspace /= "") then
           path = workspace
        else
           path = "."
        end if
     else
        path = "."
     end if
   end function workspace_path
 
   function workspace_cmd (workspace) result (cmd)
     type(string_t), intent(in), optional :: workspace
     type(string_t) :: cmd
     if (present (workspace)) then
        if (workspace /= "") then
           cmd = "cd " // workspace // " && "
        else
           cmd = ""
        end if
     else
        cmd = ""
     end if
   end function workspace_cmd
   
 @ %def workspace_prefix
 @ %def workspace_path
 @ %def workspace_cmd
 @ The first routine writes source-code files for the individual
 processes.  First it calls the writer routines directly for each
 process, then it calls [[make source]].  The make command may either
 post-process the files, or it may do the complete work, e.g., calling
 an external program the generates the files.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: make_source => prclib_driver_make_source
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_make_source (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     integer :: i
     do i = 1, driver%n_processes
        call driver%record(i)%write_source_code ()
     end do
     call os_system_call ( &
          workspace_cmd (workspace) &
          // "make source " // os_data%makeflags &
          // " -f " // driver%basename // ".makefile")
   end subroutine prclib_driver_make_source
 
 @ %def prclib_driver_make_source
 @ Compile matrix element source code and the driver source code.  As above, we
 first iterate through all processes and call [[before_compile]].  This is
 usually empty, but can execute code that depends on [[make_source]] already
 completed.  Similarly, [[after_compile]] scans all processes again.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: make_compile => prclib_driver_make_compile
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_make_compile (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     integer :: i
     do i = 1, driver%n_processes
        call driver%record(i)%before_compile ()
     end do
     call os_system_call ( &
          workspace_cmd (workspace) &
          // "make compile " // os_data%makeflags &
          // " -f " // driver%basename // ".makefile")
     do i = 1, driver%n_processes
        call driver%record(i)%after_compile ()
     end do
   end subroutine prclib_driver_make_compile
 
 @ %def prclib_driver_make_compile
 @ Combine all matrix-element code together with the driver in a
 process library on disk.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: make_link => prclib_driver_make_link
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_make_link (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     integer :: i
     call os_system_call ( &
          workspace_cmd (workspace) &
          // "make link " // os_data%makeflags &
          // " -f " // driver%basename // ".makefile")
   end subroutine prclib_driver_make_link
 
 @ %def prclib_driver_make_link
 @
 \subsection{Clean up generated files}
 The task of cleaning any generated files should also be deferred to
 Makefile targets.  Apart from removing everything, removing specific
 files may be useful for partial rebuilds.  (Note that removing the
 makefile itself can only be done once, for obvious reasons.)
 
 If there is no makefile, do nothing.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: clean_library => prclib_driver_clean_library
   procedure :: clean_objects => prclib_driver_clean_objects
   procedure :: clean_source => prclib_driver_clean_source
   procedure :: clean_driver => prclib_driver_clean_driver
   procedure :: clean_makefile => prclib_driver_clean_makefile
   procedure :: clean => prclib_driver_clean
   procedure :: distclean => prclib_driver_distclean
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_clean_library (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     if (driver%makefile_exists ()) then
        call os_system_call ( &
          workspace_cmd (workspace) &
          // "make clean-library " // os_data%makeflags &
             // " -f " // driver%basename // ".makefile")
     end if
   end subroutine prclib_driver_clean_library
 
   subroutine prclib_driver_clean_objects (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     if (driver%makefile_exists ()) then
        call os_system_call ( &
          workspace_cmd (workspace) &
          // "make clean-objects " // os_data%makeflags &
             // " -f " // driver%basename // ".makefile")
     end if
   end subroutine prclib_driver_clean_objects
 
   subroutine prclib_driver_clean_source (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     if (driver%makefile_exists ()) then
        call os_system_call ( &
          workspace_cmd (workspace) &
          // "make clean-source " // os_data%makeflags &
             // " -f " // driver%basename // ".makefile")
     end if
   end subroutine prclib_driver_clean_source
 
   subroutine prclib_driver_clean_driver (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     if (driver%makefile_exists ()) then
        call os_system_call ( &
          workspace_cmd (workspace) &
          // "make clean-driver " // os_data%makeflags &
             // " -f " // driver%basename // ".makefile")
     end if
   end subroutine prclib_driver_clean_driver
 
   subroutine prclib_driver_clean_makefile (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     if (driver%makefile_exists ()) then
        call os_system_call ( &
          workspace_cmd (workspace) &
          // "make clean-makefile " // os_data%makeflags &
             // " -f " // driver%basename // ".makefile")
     end if
   end subroutine prclib_driver_clean_makefile
 
   subroutine prclib_driver_clean (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     if (driver%makefile_exists ()) then
        call os_system_call ( &
          workspace_cmd (workspace) &
          // "make clean " // os_data%makeflags &
             // " -f " // driver%basename // ".makefile")
     end if
   end subroutine prclib_driver_clean
 
   subroutine prclib_driver_distclean (driver, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     if (driver%makefile_exists ()) then
        call os_system_call ( &
          workspace_cmd (workspace) &
          // "make distclean " // os_data%makeflags &
             // " -f " // driver%basename // ".makefile")
     end if
   end subroutine prclib_driver_distclean
 
 @ %def prclib_driver_clean_library
 @ %def prclib_driver_clean_objects
 @ %def prclib_driver_clean_source
 @ %def prclib_driver_clean_driver
 @ %def prclib_driver_clean_makefile
 @ %def prclib_driver_clean
 @ %def prclib_driver_distclean
 @ This Make target should remove all files that apply to a specific process.
 We execute this when we want to force remaking source code.  Note that source
 targets need not have prerequisites, so just calling [[make_source]] would not
 do anything if the files exist.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: clean_proc => prclib_driver_clean_proc
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_clean_proc (driver, i, os_data, workspace)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     type(string_t) :: id
     if (driver%makefile_exists ()) then
        id = driver%record(i)%id
       call os_system_call ( &
          workspace_cmd (workspace) &
          // "make clean-" // driver%record(i)%id // " " &
            // os_data%makeflags &
            // " -f " // driver%basename // ".makefile")
     end if
   end subroutine prclib_driver_clean_proc
 
 @ %def prclib_driver_clean_proc
 @
 \subsection{Further Tools}
 Check for the appropriate makefile.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: makefile_exists => prclib_driver_makefile_exists
 <<Prclib interfaces: procedures>>=
   function prclib_driver_makefile_exists (driver, workspace) result (flag)
     class(prclib_driver_t), intent(in) :: driver
     type(string_t), intent(in), optional :: workspace
     logical :: flag
     inquire (file = char (workspace_prefix (workspace) &
          &                // driver%basename) // ".makefile", &
          exist = flag)
   end function prclib_driver_makefile_exists
 
 @ %def prclib_driver_makefile_exists
 @
 \subsection{Load the library}
 Once the library has been linked, we can dlopen it and assign all
 procedure pointers to their proper places in the library driver
 object.  The [[loaded]] flag is set only if all required pointers
 have become assigned.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: load => prclib_driver_load
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_load (driver, os_data, noerror, workspace)
     class(prclib_driver_t), intent(inout) :: driver
     type(os_data_t), intent(in) :: os_data
     logical, intent(in), optional :: noerror
     type(string_t), intent(in), optional :: workspace
     type(c_funptr) :: c_fptr
     logical :: ignore
 
     ignore = .false.;  if (present (noerror))  ignore = noerror
 
     driver%libname = os_get_dlname ( &
          workspace_prefix (workspace) // driver%basename, &
          os_data, noerror, noerror)
     if (driver%libname == "")  return
     select type (driver)
     type is (prclib_driver_dynamic_t)
        if (.not. dlaccess_is_open (driver%dlaccess)) then
           call dlaccess_init &
                (driver%dlaccess, workspace_path (workspace), &
                 driver%libname, os_data)
           if (.not. ignore)  call driver%check_dlerror ()
        end if
        driver%loaded = dlaccess_is_open (driver%dlaccess)
     class default
        driver%loaded = .true.
     end select
     if (.not. driver%loaded)  return
 
     c_fptr = driver%get_c_funptr (var_str ("get_n_processes"))
     call c_f_procpointer (c_fptr, driver%get_n_processes)
     driver%loaded = driver%loaded .and. associated (driver%get_n_processes)
 
     c_fptr = driver%get_c_funptr (var_str ("get_process_id_ptr"))
     call c_f_procpointer (c_fptr, driver%get_process_id_ptr)
     driver%loaded = driver%loaded .and. associated (driver%get_process_id_ptr)
 
     c_fptr = driver%get_c_funptr (var_str ("get_model_name_ptr"))
     call c_f_procpointer (c_fptr, driver%get_model_name_ptr)
     driver%loaded = driver%loaded .and. associated (driver%get_model_name_ptr)
 
     c_fptr = driver%get_c_funptr (var_str ("get_md5sum_ptr"))
     call c_f_procpointer (c_fptr, driver%get_md5sum_ptr)
     driver%loaded = driver%loaded .and. associated (driver%get_md5sum_ptr)
 
     c_fptr = driver%get_c_funptr (var_str ("get_openmp_status"))
     call c_f_procpointer (c_fptr, driver%get_openmp_status)
     driver%loaded = driver%loaded .and. associated (driver%get_openmp_status)
 
     c_fptr = driver%get_c_funptr (var_str ("get_n_in"))
     call c_f_procpointer (c_fptr, driver%get_n_in)
     driver%loaded = driver%loaded .and. associated (driver%get_n_in)
 
     c_fptr = driver%get_c_funptr (var_str ("get_n_out"))
     call c_f_procpointer (c_fptr, driver%get_n_out)
     driver%loaded = driver%loaded .and. associated (driver%get_n_out)
 
     c_fptr = driver%get_c_funptr (var_str ("get_n_flv"))
     call c_f_procpointer (c_fptr, driver%get_n_flv)
     driver%loaded = driver%loaded .and. associated (driver%get_n_flv)
 
     c_fptr = driver%get_c_funptr (var_str ("get_n_hel"))
     call c_f_procpointer (c_fptr, driver%get_n_hel)
     driver%loaded = driver%loaded .and. associated (driver%get_n_hel)
 
     c_fptr = driver%get_c_funptr (var_str ("get_n_col"))
     call c_f_procpointer (c_fptr, driver%get_n_col)
     driver%loaded = driver%loaded .and. associated (driver%get_n_col)
 
     c_fptr = driver%get_c_funptr (var_str ("get_n_cin"))
     call c_f_procpointer (c_fptr, driver%get_n_cin)
     driver%loaded = driver%loaded .and. associated (driver%get_n_cin)
 
     c_fptr = driver%get_c_funptr (var_str ("get_n_cf"))
     call c_f_procpointer (c_fptr, driver%get_n_cf)
     driver%loaded = driver%loaded .and. associated (driver%get_n_cf)
 
     c_fptr = driver%get_c_funptr (var_str ("set_flv_state_ptr"))
     call c_f_procpointer (c_fptr, driver%set_flv_state_ptr)
     driver%loaded = driver%loaded .and. associated (driver%set_flv_state_ptr)
 
     c_fptr = driver%get_c_funptr (var_str ("set_hel_state_ptr"))
     call c_f_procpointer (c_fptr, driver%set_hel_state_ptr)
     driver%loaded = driver%loaded .and. associated (driver%set_hel_state_ptr)
 
     c_fptr = driver%get_c_funptr (var_str ("set_col_state_ptr"))
     call c_f_procpointer (c_fptr, driver%set_col_state_ptr)
     driver%loaded = driver%loaded .and. associated (driver%set_col_state_ptr)
 
     c_fptr = driver%get_c_funptr (var_str ("set_color_factors_ptr"))
     call c_f_procpointer (c_fptr, driver%set_color_factors_ptr)
     driver%loaded = driver%loaded .and. associated (driver%set_color_factors_ptr)
 
     c_fptr = driver%get_c_funptr (var_str ("get_fptr"))
     call c_f_procpointer (c_fptr, driver%get_fptr)
     driver%loaded = driver%loaded .and. associated (driver%get_fptr)
 
   end subroutine prclib_driver_load
 
 @ %def prclib_driver_load
 @ Unload.  To be sure, nullify the procedure pointers.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: unload => prclib_driver_unload
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_unload (driver)
     class(prclib_driver_t), intent(inout) :: driver
     select type (driver)
     type is (prclib_driver_dynamic_t)
        if (dlaccess_is_open (driver%dlaccess)) then
           call dlaccess_final (driver%dlaccess)
           call driver%check_dlerror ()
        end if
     end select
     driver%loaded = .false.
     nullify (driver%get_n_processes)
     nullify (driver%get_process_id_ptr)
     nullify (driver%get_model_name_ptr)
     nullify (driver%get_md5sum_ptr)
     nullify (driver%get_openmp_status)
     nullify (driver%get_n_in)
     nullify (driver%get_n_out)
     nullify (driver%get_n_flv)
     nullify (driver%get_n_hel)
     nullify (driver%get_n_col)
     nullify (driver%get_n_cin)
     nullify (driver%get_n_cf)
     nullify (driver%set_flv_state_ptr)
     nullify (driver%set_hel_state_ptr)
     nullify (driver%set_col_state_ptr)
     nullify (driver%set_color_factors_ptr)
     nullify (driver%get_fptr)
   end subroutine prclib_driver_unload
 
 @ %def prclib_driver_unload
 @ This subroutine checks the [[dlerror]] content and issues a fatal
 error if it finds an error there.
 <<Prclib interfaces: prclib driver dynamic: TBP>>=
   procedure :: check_dlerror => prclib_driver_check_dlerror
 <<Prclib interfaces: procedures>>=
   subroutine prclib_driver_check_dlerror (driver)
     class(prclib_driver_dynamic_t), intent(in) :: driver
     if (dlaccess_has_error (driver%dlaccess)) then
        call msg_fatal (char (dlaccess_get_error (driver%dlaccess)))
     end if
   end subroutine prclib_driver_check_dlerror
 
 @ %def prclib_driver_check_dlerror
 @ Get the handle (C function pointer) for a given ``feature'' of the
 matrix element code, so it can be assigned to the appropriate
 procedure pointer slot.  In the static case, this is a
 trivial pointer assignment, hard-coded into the driver type
 implementation.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure (prclib_driver_get_c_funptr), deferred :: get_c_funptr
 <<Prclib interfaces: interfaces>>=
   abstract interface
      function prclib_driver_get_c_funptr (driver, feature) result (c_fptr)
        import
        class(prclib_driver_t), intent(inout) :: driver
        type(string_t), intent(in) :: feature
        type(c_funptr) :: c_fptr
      end function prclib_driver_get_c_funptr
   end interface
 
 @ %def prclib_driver_get_c_funptr
 @ In the dynamic-library case, we call the DL interface to retrieve the C
 pointer to a named procedure.
 <<Prclib interfaces: prclib driver dynamic: TBP>>=
   procedure :: get_c_funptr => prclib_driver_dynamic_get_c_funptr
 <<Prclib interfaces: procedures>>=
   function prclib_driver_dynamic_get_c_funptr (driver, feature) result (c_fptr)
     class(prclib_driver_dynamic_t), intent(inout) :: driver
     type(string_t), intent(in) :: feature
     type(c_funptr) :: c_fptr
     type(string_t) :: prefix, full_name
     prefix = lower_case (driver%basename) // "_"
     full_name = prefix // feature
     c_fptr = dlaccess_get_c_funptr (driver%dlaccess, full_name)
     call driver%check_dlerror ()
   end function prclib_driver_dynamic_get_c_funptr
 
 @ %def prclib_driver_get_c_funptr
 @
 \subsection{MD5 sums}
 Recall the MD5 sum written in the Makefile
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: get_md5sum_makefile => prclib_driver_get_md5sum_makefile
 <<Prclib interfaces: procedures>>=
   function prclib_driver_get_md5sum_makefile (driver, workspace) result (md5sum)
     class(prclib_driver_t), intent(in) :: driver
     type(string_t), intent(in), optional :: workspace
     character(32) :: md5sum
     type(string_t) :: filename
     character(80) :: buffer
     logical :: exist
     integer :: u, iostat
     md5sum = ""
     filename = workspace_prefix (workspace) // driver%basename // ".makefile"
     inquire (file = char (filename), exist = exist)
     if (exist) then
        u = free_unit ()
        open (u, file = char (filename), action = "read", status = "old")
        iostat = 0
        do
           read (u, "(A)", iostat = iostat)  buffer
           if (iostat /= 0)  exit
           buffer = adjustl (buffer)
           select case (buffer(1:9))
           case ("MD5SUM = ")
              read (buffer(11:), "(A32)")  md5sum
              exit
           end select
        end do
        close (u)
     end if
   end function prclib_driver_get_md5sum_makefile
 
 @ %def prclib_driver_get_md5sum_makefile
 @ Recall the MD5 sum written in the driver source code.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: get_md5sum_driver => prclib_driver_get_md5sum_driver
 <<Prclib interfaces: procedures>>=
   function prclib_driver_get_md5sum_driver (driver, workspace) result (md5sum)
     class(prclib_driver_t), intent(in) :: driver
     type(string_t), intent(in), optional :: workspace
     character(32) :: md5sum
     type(string_t) :: filename
     character(80) :: buffer
     logical :: exist
     integer :: u, iostat
     md5sum = ""
     filename = workspace_prefix (workspace) // driver%basename // ".f90"
     inquire (file = char (filename), exist = exist)
     if (exist) then
        u = free_unit ()
        open (u, file = char (filename), action = "read", status = "old")
        iostat = 0
        do
           read (u, "(A)", iostat = iostat)  buffer
           if (iostat /= 0)  exit
           buffer = adjustl (buffer)
           select case (buffer(1:9))
           case ("md5sum = ")
              read (buffer(11:), "(A32)")  md5sum
              exit
           end select
        end do
        close (u)
     end if
   end function prclib_driver_get_md5sum_driver
 
 @ %def prclib_driver_get_md5sum_driver
 @ Recall the MD5 sum written in the matrix element source code.
 <<Prclib interfaces: prclib driver: TBP>>=
   procedure :: get_md5sum_source => prclib_driver_get_md5sum_source
 <<Prclib interfaces: procedures>>=
   function prclib_driver_get_md5sum_source &
        (driver, i, workspace) result (md5sum)
     class(prclib_driver_t), intent(in) :: driver
     integer, intent(in) :: i
     type(string_t), intent(in), optional :: workspace
     character(32) :: md5sum
     type(string_t) :: filename
     character(80) :: buffer
     logical :: exist
     integer :: u, iostat
     md5sum = ""
 
     filename = workspace_prefix (workspace) // driver%record(i)%id // ".f90"
     inquire (file = char (filename), exist = exist)
     if (exist) then
        u = free_unit ()
        open (u, file = char (filename), action = "read", status = "old")
        iostat = 0
        do
           read (u, "(A)", iostat = iostat)  buffer
           if (iostat /= 0)  exit
           buffer = adjustl (buffer)
           select case (buffer(1:9))
           case ("md5sum = ")
              read (buffer(11:), "(A32)")  md5sum
              exit
           end select
        end do
        close (u)
     end if
   end function prclib_driver_get_md5sum_source
 
 @ %def prclib_driver_get_md5sum_source
 @
 \subsection{Unit Test}
 Test module, followed by the corresponding implementation module.
 <<[[prclib_interfaces_ut.f90]]>>=
 <<File header>>
 
 module prclib_interfaces_ut
   use kinds
   use system_dependencies, only: CC_IS_GNU, CC_HAS_QUADMATH
   use unit_tests
   use prclib_interfaces_uti
 
 <<Standard module head>>
 
 <<Prclib interfaces: public test>>
 
 <<Prclib interfaces: public test auxiliary>>
 
 contains
 
 <<Prclib interfaces: test driver>>
 
 end module prclib_interfaces_ut
 @ %def prclib_interfaces_ut
 @
 <<[[prclib_interfaces_uti.f90]]>>=
 <<File header>>
 
 module prclib_interfaces_uti
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use kinds
   use system_dependencies, only: CC_HAS_QUADMATH, DEFAULT_FC_PRECISION
 <<Use strings>>
   use io_units
   use system_defs, only: TAB
   use os_interface
 
   use prclib_interfaces
 
 <<Standard module head>>
 
 <<Prclib interfaces: public test auxiliary>>
 
 <<Prclib interfaces: test declarations>>
 
 <<Prclib interfaces: test types>>
 
 contains
 
 <<Prclib interfaces: tests>>
 
 <<Prclib interfaces: test auxiliary>>
 
 end module prclib_interfaces_uti
 @ %def prclib_interfaces_ut
 @ API: driver for the unit tests below.
 <<Prclib interfaces: public test>>=
   public :: prclib_interfaces_test
 <<Prclib interfaces: test driver>>=
   subroutine prclib_interfaces_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Prclib interfaces: execute tests>>
   end subroutine prclib_interfaces_test
 
 @ %def prclib_interfaces_test
 @
 \subsubsection{Empty process list}
 Test 1: Create a driver object and display its contents.  One of the
 feature lists references a writer procedure; this is just a dummy that
 does nothing useful.
 <<Prclib interfaces: execute tests>>=
   call test (prclib_interfaces_1, "prclib_interfaces_1", &
        "create driver object", &
        u, results)
 <<Prclib interfaces: test declarations>>=
   public :: prclib_interfaces_1
 <<Prclib interfaces: tests>>=
   subroutine prclib_interfaces_1 (u)
     integer, intent(in) :: u
     class(prclib_driver_t), allocatable :: driver
     character(32), parameter :: md5sum = "prclib_interfaces_1_md5sum      "
     class(prc_writer_t), pointer :: test_writer_1
 
 
     write (u, "(A)")  "* Test output: prclib_interfaces_1"
     write (u, "(A)")  "*   Purpose: display the driver object contents"
     write (u, *)
     write (u, "(A)")  "* Create a prclib driver object"
     write (u, "(A)")
 
     call dispatch_prclib_driver (driver, var_str ("prclib"), var_str (""))
     call driver%init (3)
     call driver%set_md5sum (md5sum)
 
     allocate (test_writer_1_t :: test_writer_1)
 
     call driver%set_record (1, var_str ("test1"), var_str ("test_model"), &
          [var_str ("init")], test_writer_1)
 
     call driver%set_record (2, var_str ("test2"), var_str ("foo_model"), &
          [var_str ("another_proc")], test_writer_1)
 
     call driver%set_record (3, var_str ("test3"), var_str ("test_model"), &
          [var_str ("init"), var_str ("some_proc")], test_writer_1)
 
     call driver%write (u)
 
     deallocate (test_writer_1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prclib_interfaces_1"
   end subroutine prclib_interfaces_1
 
 @ %def prclib_interfaces_1
 @ The writer: the procedures write just comment lines.  We can fix an
 instance of this as a parameter (since it has no mutable content) and
 just reference the fixed parameter.
 
 NOTE: temporarily made public.
 <<Prclib interfaces: test types>>=
   type, extends (prc_writer_t) :: test_writer_1_t
    contains
      procedure, nopass :: type_name => test_writer_1_type_name
      procedure :: write_makefile_code => test_writer_1_mk
      procedure :: write_source_code => test_writer_1_src
      procedure :: write_interface => test_writer_1_if
      procedure :: write_md5sum_call => test_writer_1_md5sum
      procedure :: write_int_sub_call => test_writer_1_int_sub
      procedure :: write_col_state_call => test_writer_1_col_state
      procedure :: write_color_factors_call => test_writer_1_col_factors
      procedure :: before_compile => test_writer_1_before_compile
      procedure :: after_compile => test_writer_1_after_compile
   end type test_writer_1_t
 
 @ %def test_writer_1
 @
 <<Prclib interfaces: test auxiliary>>=
   function test_writer_1_type_name () result (string)
     type(string_t) :: string
     string = "test_1"
   end function test_writer_1_type_name
 
   subroutine test_writer_1_mk &
        (writer, unit, id, os_data, verbose, testflag)
     class(test_writer_1_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)")  "# Makefile code for process ", char (id), &
          " goes here."
   end subroutine test_writer_1_mk
 
   subroutine test_writer_1_src (writer, id)
     class(test_writer_1_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_1_src
 
   subroutine test_writer_1_if (writer, unit, id, feature)
     class(test_writer_1_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     write (unit, "(2x,9A)")  "! Interface code for ", &
        char (id), "_", char (writer%get_procname (feature)), &
        " goes here."
   end subroutine test_writer_1_if
 
   subroutine test_writer_1_md5sum (writer, unit, id)
     class(test_writer_1_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(5x,9A)")  "! MD5sum call for ", char (id), " goes here."
   end subroutine test_writer_1_md5sum
 
   subroutine test_writer_1_int_sub (writer, unit, id, feature)
     class(test_writer_1_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     write (unit, "(5x,9A)")  "! ", char (feature), " call for ", &
          char (id), " goes here."
   end subroutine test_writer_1_int_sub
 
   subroutine test_writer_1_col_state (writer, unit, id)
     class(test_writer_1_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(5x,9A)")  "! col_state call for ", &
          char (id), " goes here."
   end subroutine test_writer_1_col_state
 
   subroutine test_writer_1_col_factors (writer, unit, id)
     class(test_writer_1_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     write (unit, "(5x,9A)")  "! color_factors call for ", &
          char (id), " goes here."
   end subroutine test_writer_1_col_factors
 
   subroutine test_writer_1_before_compile (writer, id)
     class(test_writer_1_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_1_before_compile
   
   subroutine test_writer_1_after_compile (writer, id)
     class(test_writer_1_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_1_after_compile
   
 @ %def test_writer_1_type_name
 @ %def test_writer_1_mk test_writer_1_if
 @ %def test_writer_1_md5sum test_writer_1_int_sub
 @ %def test_writer_1_col_state test_writer_1_col_factors
 @ %def test_writer_1_before_compile test_writer_1_after_compile
 @
 \subsubsection{Process library driver file}
 Test 2: Write the driver file for a test case with two processes.  The
 first process needs no wrapper (C library), the second one needs
 wrappers (Fortran module library).
 <<Prclib interfaces: execute tests>>=
   call test (prclib_interfaces_2, "prclib_interfaces_2", &
        "write driver file", &
        u, results)
 <<Prclib interfaces: test declarations>>=
   public :: prclib_interfaces_2
 <<Prclib interfaces: tests>>=
   subroutine prclib_interfaces_2 (u)
     integer, intent(in) :: u
     class(prclib_driver_t), allocatable :: driver
     character(32), parameter :: md5sum = "prclib_interfaces_2_md5sum      "
     class(prc_writer_t), pointer :: test_writer_1, test_writer_2
 
     write (u, "(A)")  "* Test output: prclib_interfaces_2"
     write (u, "(A)")  "*   Purpose: check the generated driver source code"
     write (u, "(A)")
     write (u, "(A)")  "* Create a prclib driver object (2 processes)"
     write (u, "(A)")
 
     call dispatch_prclib_driver (driver, var_str ("prclib2"), var_str (""))
     call driver%init (2)
     call driver%set_md5sum (md5sum)
 
     allocate (test_writer_1_t :: test_writer_1)
     allocate (test_writer_2_t :: test_writer_2)
 
     call driver%set_record (1, var_str ("test1"), var_str ("Test_model"), &
          [var_str ("proc1")], test_writer_1)
 
     call driver%set_record (2, var_str ("test2"), var_str ("Test_model"), &
          [var_str ("proc1"), var_str ("proc2")], test_writer_2)
 
     call driver%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write the driver file"
     write (u, "(A)")  "* File contents:"
     write (u, "(A)")
 
     call driver%generate_driver_code (u)
 
     deallocate (test_writer_1)
     deallocate (test_writer_2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prclib_interfaces_2"
   end subroutine prclib_interfaces_2
 
 @ %def prclib_interfaces_2
 @ A writer with wrapper code: the procedures again write just comment
 lines.  Since all procedures are NOPASS, we can reuse two of the TBP.
 <<Prclib interfaces: test types>>=
   type, extends (prc_writer_f_module_t) :: test_writer_2_t
    contains
      procedure, nopass :: type_name => test_writer_2_type_name
      procedure :: write_makefile_code => test_writer_2_mk
      procedure :: write_source_code => test_writer_2_src
      procedure :: write_interface => test_writer_2_if
      procedure :: write_wrapper => test_writer_2_wr
      procedure :: before_compile => test_writer_2_before_compile
      procedure :: after_compile => test_writer_2_after_compile
   end type test_writer_2_t
 
 @ %def test_writer_2
 @
 <<Prclib interfaces: test auxiliary>>=
   function test_writer_2_type_name () result (string)
     type(string_t) :: string
     string = "test_2"
   end function test_writer_2_type_name
 
   subroutine test_writer_2_mk &
        (writer, unit, id, os_data, verbose, testflag)
     class(test_writer_2_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)")  "# Makefile code for process ", char (id), &
          " goes here."
   end subroutine test_writer_2_mk
 
   subroutine test_writer_2_src (writer, id)
     class(test_writer_2_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_2_src
 
   subroutine test_writer_2_if (writer, unit, id, feature)
     class(test_writer_2_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     write (unit, "(2x,9A)")  "! Interface code for ", &
        char (writer%get_module_name (id)), "_", &
        char (writer%get_procname (feature)), " goes here."
   end subroutine test_writer_2_if
 
   subroutine test_writer_2_wr (writer, unit, id, feature)
     class(test_writer_2_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     write (unit, *)
     write (unit, "(9A)")  "! Wrapper code for ", &
        char (writer%get_c_procname (id, feature)), " goes here."
   end subroutine test_writer_2_wr
 
   subroutine test_writer_2_before_compile (writer, id)
     class(test_writer_2_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_2_before_compile
   
   subroutine test_writer_2_after_compile (writer, id)
     class(test_writer_2_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_2_after_compile
   
 @ %def test_writer_2_type_name test_writer_2_wr
 @ %def test_writer_2_before_compile test_writer_2_after_compile
 @
 \subsubsection{Process library makefile}
 Test 3: Write the makefile for compiling and linking the process
 library (processes and driver code).  There are two processes, one
 with one method, one with two methods.
 
 To have predictable output, we reset the system-dependent initial
 components of [[os_data]] to known values.
 <<Prclib interfaces: execute tests>>=
   call test (prclib_interfaces_3, "prclib_interfaces_3", &
        "write makefile", &
        u, results)
 <<Prclib interfaces: test declarations>>=
   public :: prclib_interfaces_3
 <<Prclib interfaces: tests>>=
   subroutine prclib_interfaces_3 (u)
     integer, intent(in) :: u
     class(prclib_driver_t), allocatable :: driver
     type(os_data_t) :: os_data
     character(32), parameter :: md5sum = "prclib_interfaces_3_md5sum      "
     class(prc_writer_t), pointer :: test_writer_1, test_writer_2
 
     call os_data%init ()
     os_data%fc = "fortran-compiler"
     os_data%whizard_includes = "-I module-dir"
     os_data%fcflags = "-C=all"
     os_data%fcflags_pic = "-PIC"
     os_data%cc = "c-compiler"
     os_data%cflags = "-I include-dir"
     os_data%cflags_pic = "-PIC"
     os_data%whizard_ldflags = ""
     os_data%ldflags = ""
     os_data%whizard_libtool = "my-libtool"
     os_data%latex = "latex -halt-on-error"
     os_data%mpost = "mpost --math=scaled -halt-on-error"
     os_data%dvips = "dvips"
     os_data%ps2pdf = "ps2pdf14"
     os_data%whizard_texpath = ""
 
     write (u, "(A)")  "* Test output: prclib_interfaces_3"
     write (u, "(A)")  "*   Purpose: check the generated Makefile"
     write (u, *)
     write (u, "(A)")  "* Create a prclib driver object (2 processes)"
     write (u, "(A)")
 
     call dispatch_prclib_driver (driver, var_str ("prclib3"), var_str (""))
     call driver%init (2)
     call driver%set_md5sum (md5sum)
 
     allocate (test_writer_1_t :: test_writer_1)
     allocate (test_writer_2_t :: test_writer_2)
 
     call driver%set_record (1, var_str ("test1"), var_str ("Test_model"), &
          [var_str ("proc1")], test_writer_1)
 
     call driver%set_record (2, var_str ("test2"), var_str ("Test_model"), &
          [var_str ("proc1"), var_str ("proc2")], test_writer_2)
 
     call driver%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write Makefile"
     write (u, "(A)")  "* File contents:"
     write (u, "(A)")
 
     call driver%generate_makefile (u, os_data, verbose = .true.)
 
     deallocate (test_writer_1)
     deallocate (test_writer_2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prclib_interfaces_3"
   end subroutine prclib_interfaces_3
 
 @ %def prclib_interfaces_3
 @
 \subsubsection{Compile test with Fortran module}
 Test 4: Write driver and makefile and try to compile and link the
 library driver.
 
 There is a single test process with a single feature.  The process
 code is provided as a Fortran module, therefore we need a wrapper for
 the featured procedure.
 <<Prclib interfaces: execute tests>>=
   call test (prclib_interfaces_4, "prclib_interfaces_4", &
        "compile and link (Fortran module)", &
        u, results)
 <<Prclib interfaces: test declarations>>=
   public :: prclib_interfaces_4
 <<Prclib interfaces: tests>>=
   subroutine prclib_interfaces_4 (u)
     integer, intent(in) :: u
     class(prclib_driver_t), allocatable :: driver
     class(prc_writer_t), pointer :: test_writer_4
     type(os_data_t) :: os_data
     integer :: u_file
 
     integer, dimension(:,:), allocatable :: flv_state
     integer, dimension(:,:), allocatable :: hel_state
     integer, dimension(:,:,:), allocatable :: col_state
     logical, dimension(:,:), allocatable :: ghost_flag
     integer, dimension(:,:), allocatable :: cf_index
     complex(default), dimension(:), allocatable :: color_factors
     character(32), parameter :: md5sum = "prclib_interfaces_4_md5sum      "
     character(32) :: md5sum_file
 
     type(c_funptr) :: proc1_ptr
     interface
        subroutine proc1_t (n) bind(C)
          import
          integer(c_int), intent(out) :: n
        end subroutine proc1_t
     end interface
     procedure(proc1_t), pointer :: proc1
     integer(c_int) :: n
 
     write (u, "(A)")  "* Test output: prclib_interfaces_4"
     write (u, "(A)")  "*   Purpose: compile, link, and load process library"
     write (u, "(A)")  "*            with (fake) matrix-element code &
          &as a Fortran module"
     write (u, *)
     write (u, "(A)")  "* Create a prclib driver object (1 process)"
     write (u, "(A)")
 
     call os_data%init ()
 
     allocate (test_writer_4_t :: test_writer_4)
     call test_writer_4%init_test ()
 
     call dispatch_prclib_driver (driver, var_str ("prclib4"), var_str (""))
     call driver%init (1)
     call driver%set_md5sum (md5sum)
 
     call driver%set_record (1, var_str ("test4"), var_str ("Test_model"), &
          [var_str ("proc1")], test_writer_4)
 
     call driver%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Write Makefile"
     u_file = free_unit ()
     open (u_file, file="prclib4.makefile", status="replace", action="write")
     call driver%generate_makefile (u_file, os_data, verbose = .false.)
     close (u_file)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recall MD5 sum from Makefile"
     write (u, "(A)")
 
     md5sum_file = driver%get_md5sum_makefile ()
     write (u, "(1x,A,A,A)")  "MD5 sum = '", md5sum_file, "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Write driver source code"
 
     u_file = free_unit ()
     open (u_file, file="prclib4.f90", status="replace", action="write")
     call driver%generate_driver_code (u_file)
     close (u_file)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recall MD5 sum from driver source"
     write (u, "(A)")
 
     md5sum_file = driver%get_md5sum_driver ()
     write (u, "(1x,A,A,A)")  "MD5 sum = '", md5sum_file, "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Write matrix-element source code"
     call driver%make_source (os_data)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recall MD5 sum from matrix-element source"
     write (u, "(A)")
 
     md5sum_file = driver%get_md5sum_source (1)
     write (u, "(1x,A,A,A)")  "MD5 sum = '", md5sum_file, "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile source code"
     call driver%make_compile (os_data)
 
     write (u, "(A)")  "* Link library"
     call driver%make_link (os_data)
 
     write (u, "(A)")  "* Load library"
     call driver%load (os_data)
 
     write (u, *)
     call driver%write (u)
     write (u, *)
 
     if (driver%loaded) then
        write (u, "(A)")  "* Call library functions:"
        write (u, *)
        write (u, "(1x,A,I0)")  "n_processes   = ", driver%get_n_processes ()
        write (u, "(1x,A,A,A)")  "process_id    = '", &
             char (driver%get_process_id (1)), "'"
        write (u, "(1x,A,A,A)")  "model_name    = '", &
             char (driver%get_model_name (1)), "'"
        write (u, "(1x,A,A,A)")  "md5sum (lib)  = '", &
             char (driver%get_md5sum (0)), "'"
        write (u, "(1x,A,A,A)")  "md5sum (proc) = '", &
             char (driver%get_md5sum (1)), "'"
        write (u, "(1x,A,L1)")  "openmp_status = ", driver%get_openmp_status (1)
        write (u, "(1x,A,I0)")  "n_in  = ", driver%get_n_in (1)
        write (u, "(1x,A,I0)")  "n_out = ", driver%get_n_out (1)
        write (u, "(1x,A,I0)")  "n_flv = ", driver%get_n_flv (1)
        write (u, "(1x,A,I0)")  "n_hel = ", driver%get_n_hel (1)
        write (u, "(1x,A,I0)")  "n_col = ", driver%get_n_col (1)
        write (u, "(1x,A,I0)")  "n_cin = ", driver%get_n_cin (1)
        write (u, "(1x,A,I0)")  "n_cf  = ", driver%get_n_cf (1)
 
        call driver%set_flv_state (1, flv_state)
        write (u, "(1x,A,10(1x,I0))")  "flv_state =", flv_state
 
        call driver%set_hel_state (1, hel_state)
        write (u, "(1x,A,10(1x,I0))")  "hel_state =", hel_state
 
        call driver%set_col_state (1, col_state, ghost_flag)
        write (u, "(1x,A,10(1x,I0))")  "col_state =", col_state
        write (u, "(1x,A,10(1x,L1))")  "ghost_flag =", ghost_flag
 
        call driver%set_color_factors (1, color_factors, cf_index)
        write (u, "(1x,A,10(1x,F5.3))")  "color_factors =", color_factors
        write (u, "(1x,A,10(1x,I0))")  "cf_index =", cf_index
 
        call driver%get_fptr (1, 1, proc1_ptr)
        call c_f_procpointer (proc1_ptr, proc1)
        if (associated (proc1)) then
           write (u, *)
           call proc1 (n)
           write (u, "(1x,A,I0)")  "proc1(1) = ", n
        end if
 
     end if
 
     deallocate (test_writer_4)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prclib_interfaces_4"
   end subroutine prclib_interfaces_4
 
 @ %def prclib_interfaces_4
 @ This version of test-code writer actually writes an interface and
 wrapper code.  The wrapped function is a no-parameter function with integer
 result.
 
 The stored MD5 sum may be modified.
 
 We will reuse this later, therefore public.
 <<Prclib interfaces: public test auxiliary>>=
   public :: test_writer_4_t
 <<Prclib interfaces: test types>>=
   type, extends (prc_writer_f_module_t) :: test_writer_4_t
    contains
      procedure, nopass :: type_name => test_writer_4_type_name
      procedure, nopass :: get_module_name => &
           test_writer_4_get_module_name
      procedure :: write_makefile_code => test_writer_4_mk
      procedure :: write_source_code => test_writer_4_src
      procedure :: write_interface => test_writer_4_if
      procedure :: write_wrapper => test_writer_4_wr
      procedure :: before_compile => test_writer_4_before_compile
      procedure :: after_compile => test_writer_4_after_compile
   end type test_writer_4_t
 
 @ %def test_writer_4
 @
 <<Prclib interfaces: test auxiliary>>=
   function test_writer_4_type_name () result (string)
     type(string_t) :: string
     string = "test_4"
   end function test_writer_4_type_name
 
   function test_writer_4_get_module_name (id) result (name)
     type(string_t), intent(in) :: id
     type(string_t) :: name
     name = "tpr_" // id
   end function test_writer_4_get_module_name
 
   subroutine test_writer_4_mk &
        (writer, unit, id, os_data, verbose, testflag)
     class(test_writer_4_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_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 test_writer_4_mk
 
   subroutine test_writer_4_src (writer, id)
     class(test_writer_4_t), intent(in) :: writer
     type(string_t), intent(in) :: id
     call write_test_module_file (id, var_str ("proc1"), writer%md5sum)
   end subroutine test_writer_4_src
 
   subroutine test_writer_4_if (writer, unit, id, feature)
     class(test_writer_4_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     write (unit, "(2x,9A)")  "interface"
     write (unit, "(5x,9A)")  "subroutine ", &
        char (writer%get_c_procname (id, feature)), &
        " (n) bind(C)"
     write (unit, "(7x,9A)")  "import"
     write (unit, "(7x,9A)")  "implicit none"
     write (unit, "(7x,9A)")  "integer(c_int), intent(out) :: n"
     write (unit, "(5x,9A)")  "end subroutine ", &
        char (writer%get_c_procname (id, feature))
     write (unit, "(2x,9A)")  "end interface"
   end subroutine test_writer_4_if
 
   subroutine test_writer_4_wr (writer, unit, id, feature)
     class(test_writer_4_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     write (unit, *)
     write (unit, "(9A)")  "subroutine ", &
          char (writer%get_c_procname (id, feature)), &
        " (n) bind(C)"
     write (unit, "(2x,9A)")  "use iso_c_binding"
     write (unit, "(2x,9A)")  "use tpr_", char (id), ", only: ", &
          char (writer%get_procname (feature))
     write (unit, "(2x,9A)")  "implicit none"
     write (unit, "(2x,9A)")  "integer(c_int), intent(out) :: n"
     write (unit, "(2x,9A)")  "call ", char (feature), " (n)"
     write (unit, "(9A)")  "end subroutine ", &
        char (writer%get_c_procname (id, feature))
   end subroutine test_writer_4_wr
 
   subroutine test_writer_4_before_compile (writer, id)
     class(test_writer_4_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_4_before_compile
   
   subroutine test_writer_4_after_compile (writer, id)
     class(test_writer_4_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_4_after_compile
   
 @ %def test_writer_2_type_name test_writer_4_wr
 @ %def test_writer_4_before_compile test_writer_4_after_compile
 @
 We need a test module file (actually, one for each process in the test
 above) that allows us to check compilation and linking.  The test
 module implements a colorless $1\to 2$ process, and it implements one
 additional function (feature), the name given as an argument.
 <<Prclib interfaces: test auxiliary>>=
   subroutine write_test_module_file (basename, feature, md5sum)
     type(string_t), intent(in) :: basename
     type(string_t), intent(in) :: feature
     character(32), intent(in) :: md5sum
     integer :: u
     u = free_unit ()
     open (u, file = char (basename) // ".f90", &
          status = "replace", action = "write")
     write (u, "(A)")  "! (Pseudo) matrix element code file &
          &for WHIZARD self-test"
     write (u, *)
     write (u, "(A)")  "module tpr_" // char (basename)
     write (u, *)
     write (u, "(2x,A)")  "use kinds"
     write (u, "(2x,A)")  "use omega_color, OCF => omega_color_factor"
     write (u, *)
     write (u, "(2x,A)")  "implicit none"
     write (u, "(2x,A)")  "private"
     write (u, *)
     call write_test_me_code_1 (u)
     write (u, *)
     write (u, "(2x,A)")  "public :: " // char (feature)
     write (u, *)
     write (u, "(A)")  "contains"
     write (u, *)
     call write_test_me_code_2 (u, md5sum)
     write (u, *)
     write (u, "(2x,A)")  "subroutine " // char (feature) // " (n)"
     write (u, "(2x,A)")  "  integer, intent(out) :: n"
     write (u, "(2x,A)")  "  n = 42"
     write (u, "(2x,A)")  "end subroutine " // char (feature)
     write (u, *)
     write (u, "(A)")  "end module tpr_" // char (basename)
     close (u)
   end subroutine write_test_module_file
 
 @ %def write_test_module_file
 @
 The following two subroutines provide building blocks for a
 matrix-element source code file, useful only for testing the
 workflow.  The first routine writes the header part, the other routine
 the implementation of the procedures listed in the header.
 <<Prclib interfaces: test auxiliary>>=
   subroutine write_test_me_code_1 (u)
     integer, intent(in) :: u
     write (u, "(2x,A)")  "public :: md5sum"
     write (u, "(2x,A)")  "public :: openmp_supported"
     write (u, *)
     write (u, "(2x,A)")  "public :: n_in"
     write (u, "(2x,A)")  "public :: n_out"
     write (u, "(2x,A)")  "public :: n_flv"
     write (u, "(2x,A)")  "public :: n_hel"
     write (u, "(2x,A)")  "public :: n_cin"
     write (u, "(2x,A)")  "public :: n_col"
     write (u, "(2x,A)")  "public :: n_cf"
     write (u, *)
     write (u, "(2x,A)")  "public :: flv_state"
     write (u, "(2x,A)")  "public :: hel_state"
     write (u, "(2x,A)")  "public :: col_state"
     write (u, "(2x,A)")  "public :: color_factors"
   end subroutine write_test_me_code_1
 
   subroutine write_test_me_code_2 (u, md5sum)
     integer, intent(in) :: u
     character(32), intent(in) :: md5sum
     write (u, "(2x,A)")  "pure function md5sum ()"
     write (u, "(2x,A)")  "  character(len=32) :: md5sum"
     write (u, "(2x,A)")  "  md5sum = '" // md5sum // "'"
     write (u, "(2x,A)")  "end function md5sum"
     write (u, *)
     write (u, "(2x,A)")  "pure function openmp_supported () result (status)"
     write (u, "(2x,A)")  "  logical :: status"
     write (u, "(2x,A)")  "  status = .false."
     write (u, "(2x,A)")  "end function openmp_supported"
     write (u, *)
     write (u, "(2x,A)")  "pure function n_in () result (n)"
     write (u, "(2x,A)")  "  integer :: n"
     write (u, "(2x,A)")  "  n = 1"
     write (u, "(2x,A)")  "end function n_in"
     write (u, *)
     write (u, "(2x,A)")  "pure function n_out () result (n)"
     write (u, "(2x,A)")  "  integer :: n"
     write (u, "(2x,A)")  "  n = 2"
     write (u, "(2x,A)")  "end function n_out"
     write (u, *)
     write (u, "(2x,A)")  "pure function n_flv () result (n)"
     write (u, "(2x,A)")  "  integer :: n"
     write (u, "(2x,A)")  "  n = 1"
     write (u, "(2x,A)")  "end function n_flv"
     write (u, *)
     write (u, "(2x,A)")  "pure function n_hel () result (n)"
     write (u, "(2x,A)")  "  integer :: n"
     write (u, "(2x,A)")  "  n = 1"
     write (u, "(2x,A)")  "end function n_hel"
     write (u, *)
     write (u, "(2x,A)")  "pure function n_cin () result (n)"
     write (u, "(2x,A)")  "  integer :: n"
     write (u, "(2x,A)")  "  n = 2"
     write (u, "(2x,A)")  "end function n_cin"
     write (u, *)
     write (u, "(2x,A)")  "pure function n_col () result (n)"
     write (u, "(2x,A)")  "  integer :: n"
     write (u, "(2x,A)")  "  n = 1"
     write (u, "(2x,A)")  "end function n_col"
     write (u, *)
     write (u, "(2x,A)")  "pure function n_cf () result (n)"
     write (u, "(2x,A)")  "  integer :: n"
     write (u, "(2x,A)")  "  n = 1"
     write (u, "(2x,A)")  "end function n_cf"
     write (u, *)
     write (u, "(2x,A)")  "pure subroutine flv_state (a)"
     write (u, "(2x,A)")  "  integer, dimension(:,:), intent(out) :: a"
     write (u, "(2x,A)")  "  a = reshape ([1,2,3], [3,1])"
     write (u, "(2x,A)")  "end subroutine flv_state"
     write (u, *)
     write (u, "(2x,A)")  "pure subroutine hel_state (a)"
     write (u, "(2x,A)")  "  integer, dimension(:,:), intent(out) :: a"
     write (u, "(2x,A)")  "  a = reshape ([0,0,0], [3,1])"
     write (u, "(2x,A)")  "end subroutine hel_state"
     write (u, *)
     write (u, "(2x,A)")  "pure subroutine col_state (a, g)"
     write (u, "(2x,A)")  "  integer, dimension(:,:,:), intent(out) :: a"
     write (u, "(2x,A)")  "  logical, dimension(:,:), intent(out) :: g"
     write (u, "(2x,A)")  "  a = reshape ([0,0, 0,0, 0,0], [2,3,1])"
     write (u, "(2x,A)")  "  g = reshape ([.false., .false., .false.], [3,1])"
     write (u, "(2x,A)")  "end subroutine col_state"
     write (u, *)
     write (u, "(2x,A)")  "pure subroutine color_factors (cf)"
     write (u, "(2x,A)")  "  type(OCF), dimension(:), intent(out) :: cf"
     write (u, "(2x,A)")  "  cf = [ OCF(1,1,+1._default) ]"
     write (u, "(2x,A)")  "end subroutine color_factors"
   end subroutine write_test_me_code_2
 
 @ %def write_test_me_code_1 write_test_me_code_2
 @
 \subsubsection{Compile test with Fortran bind(C) library}
 Test 5: Write driver and makefile and try to compile and link the
 library driver.
 
 There is a single test process with a single feature.  The process
 code is provided as a Fortran library of independent procedures.
 These procedures are bind(C).
 <<Prclib interfaces: execute tests>>=
   call test (prclib_interfaces_5, "prclib_interfaces_5", &
        "compile and link (Fortran library)", &
        u, results)
 <<Prclib interfaces: test declarations>>=
   public :: prclib_interfaces_5
 <<Prclib interfaces: tests>>=
   subroutine prclib_interfaces_5 (u)
     integer, intent(in) :: u
     class(prclib_driver_t), allocatable :: driver
     class(prc_writer_t), pointer :: test_writer_5
     type(os_data_t) :: os_data
     integer :: u_file
 
     integer, dimension(:,:), allocatable :: flv_state
     integer, dimension(:,:), allocatable :: hel_state
     integer, dimension(:,:,:), allocatable :: col_state
     logical, dimension(:,:), allocatable :: ghost_flag
     integer, dimension(:,:), allocatable :: cf_index
     complex(default), dimension(:), allocatable :: color_factors
     character(32), parameter :: md5sum = "prclib_interfaces_5_md5sum      "
 
     type(c_funptr) :: proc1_ptr
     interface
        subroutine proc1_t (n) bind(C)
          import
          integer(c_int), intent(out) :: n
        end subroutine proc1_t
     end interface
     procedure(proc1_t), pointer :: proc1
     integer(c_int) :: n
 
     write (u, "(A)")  "* Test output: prclib_interfaces_5"
     write (u, "(A)")  "*   Purpose: compile, link, and load process library"
     write (u, "(A)")  "*            with (fake) matrix-element code &
          &as a Fortran bind(C) library"
     write (u, *)
     write (u, "(A)")  "* Create a prclib driver object (1 process)"
     write (u, "(A)")
 
     call os_data%init ()
     allocate (test_writer_5_t :: test_writer_5)
 
     call dispatch_prclib_driver (driver, var_str ("prclib5"), var_str (""))
     call driver%init (1)
     call driver%set_md5sum (md5sum)
 
     call driver%set_record (1, var_str ("test5"), var_str ("Test_model"), &
          [var_str ("proc1")], test_writer_5)
 
     call driver%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Write makefile"
     u_file = free_unit ()
     open (u_file, file="prclib5.makefile", status="replace", action="write")
     call driver%generate_makefile (u_file, os_data, verbose = .false.)
     close (u_file)
 
     write (u, "(A)")  "* Write driver source code"
     u_file = free_unit ()
     open (u_file, file="prclib5.f90", status="replace", action="write")
     call driver%generate_driver_code (u_file)
     close (u_file)
 
     write (u, "(A)")  "* Write matrix-element source code"
     call driver%make_source (os_data)
 
     write (u, "(A)")  "* Compile source code"
     call driver%make_compile (os_data)
 
     write (u, "(A)")  "* Link library"
     call driver%make_link (os_data)
 
     write (u, "(A)")  "* Load library"
     call driver%load (os_data)
 
     write (u, *)
     call driver%write (u)
     write (u, *)
 
     if (driver%loaded) then
        write (u, "(A)")  "* Call library functions:"
        write (u, *)
        write (u, "(1x,A,I0)")  "n_processes   = ", driver%get_n_processes ()
        write (u, "(1x,A,A)")  "process_id    = ", &
             char (driver%get_process_id (1))
        write (u, "(1x,A,A)")  "model_name    = ", &
             char (driver%get_model_name (1))
        write (u, "(1x,A,A)")  "md5sum        = ", &
             char (driver%get_md5sum (1))
        write (u, "(1x,A,L1)")  "openmp_status = ", driver%get_openmp_status (1)
        write (u, "(1x,A,I0)")  "n_in  = ", driver%get_n_in (1)
        write (u, "(1x,A,I0)")  "n_out = ", driver%get_n_out (1)
        write (u, "(1x,A,I0)")  "n_flv = ", driver%get_n_flv (1)
        write (u, "(1x,A,I0)")  "n_hel = ", driver%get_n_hel (1)
        write (u, "(1x,A,I0)")  "n_col = ", driver%get_n_col (1)
        write (u, "(1x,A,I0)")  "n_cin = ", driver%get_n_cin (1)
        write (u, "(1x,A,I0)")  "n_cf  = ", driver%get_n_cf (1)
 
        call driver%set_flv_state (1, flv_state)
        write (u, "(1x,A,10(1x,I0))")  "flv_state =", flv_state
 
        call driver%set_hel_state (1, hel_state)
        write (u, "(1x,A,10(1x,I0))")  "hel_state =", hel_state
 
        call driver%set_col_state (1, col_state, ghost_flag)
        write (u, "(1x,A,10(1x,I0))")  "col_state =", col_state
        write (u, "(1x,A,10(1x,L1))")  "ghost_flag =", ghost_flag
 
        call driver%set_color_factors (1, color_factors, cf_index)
        write (u, "(1x,A,10(1x,F5.3))")  "color_factors =", color_factors
        write (u, "(1x,A,10(1x,I0))")  "cf_index =", cf_index
 
        call driver%get_fptr (1, 1, proc1_ptr)
        call c_f_procpointer (proc1_ptr, proc1)
        if (associated (proc1)) then
           write (u, *)
           call proc1 (n)
           write (u, "(1x,A,I0)")  "proc1(1) = ", n
        end if
 
     end if
 
     deallocate (test_writer_5)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prclib_interfaces_5"
   end subroutine prclib_interfaces_5
 
 @ %def prclib_interfaces_5
 @ This version of test-code writer writes interfaces for all standard
 features plus one specific feature.  The interfaces are all bind(C),
 so no wrapper is needed.
 <<Prclib interfaces: test types>>=
   type, extends (prc_writer_c_lib_t) :: test_writer_5_t
    contains
      procedure, nopass :: type_name => test_writer_5_type_name
      procedure :: write_makefile_code => test_writer_5_mk
      procedure :: write_source_code => test_writer_5_src
      procedure :: write_interface => test_writer_5_if
      procedure :: before_compile => test_writer_5_before_compile
      procedure :: after_compile => test_writer_5_after_compile
   end type test_writer_5_t
 
 @ %def test_writer_5
 @ The
 <<Prclib interfaces: test auxiliary>>=
   function test_writer_5_type_name () result (string)
     type(string_t) :: string
     string = "test_5"
   end function test_writer_5_type_name
 
   subroutine test_writer_5_mk &
        (writer, unit, id, os_data, verbose, testflag)
     class(test_writer_5_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)")  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 test_writer_5_mk
 
   subroutine test_writer_5_src (writer, id)
     class(test_writer_5_t), intent(in) :: writer
     type(string_t), intent(in) :: id
     call write_test_f_lib_file (id, var_str ("proc1"))
   end subroutine test_writer_5_src
 
   subroutine test_writer_5_if (writer, unit, id, feature)
     class(test_writer_5_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     select case (char (feature))
     case ("proc1")
        write (unit, "(2x,9A)")  "interface"
        write (unit, "(5x,9A)")  "subroutine ", &
             char (writer%get_c_procname (id, feature)), &
             " (n) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "implicit none"
        write (unit, "(7x,9A)")  "integer(c_int), intent(out) :: n"
        write (unit, "(5x,9A)")  "end subroutine ", &
             char (writer%get_c_procname (id, feature))
        write (unit, "(2x,9A)")  "end interface"
     case default
        call writer%write_standard_interface (unit, id, feature)
     end select
   end subroutine test_writer_5_if
 
   subroutine test_writer_5_before_compile (writer, id)
     class(test_writer_5_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_5_before_compile
   
   subroutine test_writer_5_after_compile (writer, id)
     class(test_writer_5_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine test_writer_5_after_compile
   
 @ %def test_writer_5_type_name test_writer_5_mk
 @ %def test_writer_5_if
 @ %def test_writer_5_before_compile test_writer_5_after_compile
 @
 We need a test module file (actually, one for each process in the test
 above) that allows us to check compilation and linking.  The test
 module implements a colorless $1\to 2$ process, and it implements one
 additional function (feature), the name given as an argument.
 <<Prclib interfaces: test auxiliary>>=
   subroutine write_test_f_lib_file (basename, feature)
     type(string_t), intent(in) :: basename
     type(string_t), intent(in) :: feature
     integer :: u
     u = free_unit ()
     open (u, file = char (basename) // ".f90", &
          status = "replace", action = "write")
     write (u, "(A)")  "! (Pseudo) matrix element code file &
          &for WHIZARD self-test"
     call write_test_me_code_3 (u, char (basename))
     write (u, *)
     write (u, "(A)")  "subroutine " // char (basename) // "_" &
          // char (feature) // " (n) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int), intent(out) :: n"
     write (u, "(A)")  "  n = 42"
     write (u, "(A)")  "end subroutine " // char (basename) // "_" &
          // char (feature)
     close (u)
   end subroutine write_test_f_lib_file
 
 @ %def write_test_module_file
 @
 The following matrix-element source code is identical to the previous
 one, but modified such as to provide independent procedures without a
 module envelope.
 <<Prclib interfaces: test auxiliary>>=
   subroutine write_test_me_code_3 (u, id)
     integer, intent(in) :: u
     character(*), intent(in) :: id
     write (u, "(A)")  "function " // id // "_get_md5sum () &
          &result (cptr) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  type(c_ptr) :: cptr"
     write (u, "(A)")  "  character(c_char), dimension(32), &
          &target, save :: md5sum"
     write (u, "(A)")  "  md5sum = copy (c_char_&
          &'1234567890abcdef1234567890abcdef')"
     write (u, "(A)")  "  cptr = c_loc (md5sum)"
     write (u, "(A)")  "contains"
     write (u, "(A)")  "  function copy (md5sum)"
     write (u, "(A)")  "    character(c_char), dimension(32) :: copy"
     write (u, "(A)")  "    character(c_char), dimension(32), intent(in) :: &
          &md5sum"
     write (u, "(A)")  "    copy = md5sum"
     write (u, "(A)")  "  end function copy"
     write (u, "(A)")  "end function " // id // "_get_md5sum"
     write (u, *)
     write (u, "(A)")  "function " // id // "_openmp_supported () &
          &result (status) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  logical(c_bool) :: status"
     write (u, "(A)")  "  status = .false."
     write (u, "(A)")  "end function " // id // "_openmp_supported"
     write (u, *)
     write (u, "(A)")  "function " // id // "_n_in () result (n) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int) :: n"
     write (u, "(A)")  "  n = 1"
     write (u, "(A)")  "end function " // id // "_n_in"
     write (u, *)
     write (u, "(A)")  "function " // id // "_n_out () result (n) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int) :: n"
     write (u, "(A)")  "  n = 2"
     write (u, "(A)")  "end function " // id // "_n_out"
     write (u, *)
     write (u, "(A)")  "function " // id // "_n_flv () result (n) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int) :: n"
     write (u, "(A)")  "  n = 1"
     write (u, "(A)")  "end function " // id // "_n_flv"
     write (u, *)
     write (u, "(A)")  "function " // id // "_n_hel () result (n) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int) :: n"
     write (u, "(A)")  "  n = 1"
     write (u, "(A)")  "end function " // id // "_n_hel"
     write (u, *)
     write (u, "(A)")  "function " // id // "_n_cin () result (n) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int) :: n"
     write (u, "(A)")  "  n = 2"
     write (u, "(A)")  "end function " // id // "_n_cin"
     write (u, *)
     write (u, "(A)")  "function " // id // "_n_col () result (n) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int) :: n"
     write (u, "(A)")  "  n = 1"
     write (u, "(A)")  "end function " // id // "_n_col"
     write (u, *)
     write (u, "(A)")  "function " // id // "_n_cf () result (n) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int) :: n"
     write (u, "(A)")  "  n = 1"
     write (u, "(A)")  "end function " // id // "_n_cf"
     write (u, *)
     write (u, "(A)")  "subroutine " // id // "_flv_state (flv_state) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int), dimension(*), intent(out) :: flv_state"
     write (u, "(A)")  "  flv_state(1:3) = [1,2,3]"
     write (u, "(A)")  "end subroutine " // id // "_flv_state"
     write (u, *)
     write (u, "(A)")  "subroutine " // id // "_hel_state (hel_state) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int), dimension(*), intent(out) :: hel_state"
     write (u, "(A)")  "  hel_state(1:3) = [0,0,0]"
     write (u, "(A)")  "end subroutine " // id // "_hel_state"
     write (u, *)
     write (u, "(A)")  "subroutine " // id // "_col_state &
          &(col_state, ghost_flag) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int), dimension(*), intent(out) &
          &:: col_state"
     write (u, "(A)")  "  logical(c_bool), dimension(*), intent(out) &
          &:: ghost_flag"
     write (u, "(A)")  "  col_state(1:6) = [0,0, 0,0, 0,0]"
     write (u, "(A)")  "  ghost_flag(1:3) = [.false., .false., .false.]"
     write (u, "(A)")  "end subroutine " // id // "_col_state"
     write (u, *)
     write (u, "(A)")  "subroutine " // id // "_color_factors &
          &(cf_index1, cf_index2, color_factors) bind(C)"
     write (u, "(A)")  "  use iso_c_binding"
     write (u, "(A)")  "  use kinds"
     write (u, "(A)")  "  implicit none"
     write (u, "(A)")  "  integer(c_int), dimension(*), intent(out) :: cf_index1"
     write (u, "(A)")  "  integer(c_int), dimension(*), intent(out) :: cf_index2"
     write (u, "(A)")  "  complex(c_default_complex), dimension(*), &
          &intent(out) :: color_factors"
     write (u, "(A)")  "  cf_index1(1:1) = [1]"
     write (u, "(A)")  "  cf_index2(1:1) = [1]"
     write (u, "(A)")  "  color_factors(1:1) = [1]"
     write (u, "(A)")  "end subroutine " // id // "_color_factors"
   end subroutine write_test_me_code_3
 
 @ %def write_test_me_code_3
 @
 \subsubsection{Compile test with genuine C library}
 Test 6: Write driver and makefile and try to compile and link the
 library driver.
 
 There is a single test process with a single feature.  The process
 code is provided as a C library of independent procedures.
 These procedures should match the Fortran bind(C) interface.
 <<Prclib interfaces: execute tests>>=
   if (default == double .or. (CC_IS_GNU .and. CC_HAS_QUADMATH)) then
      call test (prclib_interfaces_6, "prclib_interfaces_6", &
           "compile and link (C library)", &
           u, results)
   end if
 <<Prclib interfaces: test declarations>>=
   public :: prclib_interfaces_6
 <<Prclib interfaces: tests>>=
   subroutine prclib_interfaces_6 (u)
     integer, intent(in) :: u
     class(prclib_driver_t), allocatable :: driver
     class(prc_writer_t), pointer :: test_writer_6
     type(os_data_t) :: os_data
     integer :: u_file
 
     integer, dimension(:,:), allocatable :: flv_state
     integer, dimension(:,:), allocatable :: hel_state
     integer, dimension(:,:,:), allocatable :: col_state
     logical, dimension(:,:), allocatable :: ghost_flag
     integer, dimension(:,:), allocatable :: cf_index
     complex(default), dimension(:), allocatable :: color_factors
     character(32), parameter :: md5sum = "prclib_interfaces_6_md5sum      "
 
     type(c_funptr) :: proc1_ptr
     interface
        subroutine proc1_t (n) bind(C)
          import
          integer(c_int), intent(out) :: n
        end subroutine proc1_t
     end interface
     procedure(proc1_t), pointer :: proc1
     integer(c_int) :: n
 
     write (u, "(A)")  "* Test output: prclib_interfaces_6"
     write (u, "(A)")  "*   Purpose: compile, link, and load process library"
     write (u, "(A)")  "*            with (fake) matrix-element code &
          &as a C library"
     write (u, *)
     write (u, "(A)")  "* Create a prclib driver object (1 process)"
     write (u, "(A)")
 
     call os_data%init ()
     allocate (test_writer_6_t :: test_writer_6)
 
     call dispatch_prclib_driver (driver, var_str ("prclib6"), var_str (""))
     call driver%init (1)
     call driver%set_md5sum (md5sum)
 
     call driver%set_record (1, var_str ("test6"), var_str ("Test_model"), &
          [var_str ("proc1")], test_writer_6)
 
     call driver%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Write makefile"
     u_file = free_unit ()
     open (u_file, file="prclib6.makefile", status="replace", action="write")
     call driver%generate_makefile (u_file, os_data, verbose = .false.)
     close (u_file)
 
     write (u, "(A)")  "* Write driver source code"
     u_file = free_unit ()
     open (u_file, file="prclib6.f90", status="replace", action="write")
     call driver%generate_driver_code (u_file)
     close (u_file)
 
     write (u, "(A)")  "* Write matrix-element source code"
     call driver%make_source (os_data)
 
     write (u, "(A)")  "* Compile source code"
     call driver%make_compile (os_data)
 
     write (u, "(A)")  "* Link library"
     call driver%make_link (os_data)
 
     write (u, "(A)")  "* Load library"
     call driver%load (os_data)
 
     write (u, *)
     call driver%write (u)
     write (u, *)
 
     if (driver%loaded) then
        write (u, "(A)")  "* Call library functions:"
        write (u, *)
        write (u, "(1x,A,I0)")  "n_processes   = ", driver%get_n_processes ()
        write (u, "(1x,A,A)")  "process_id    = ", &
             char (driver%get_process_id (1))
        write (u, "(1x,A,A)")  "model_name    = ", &
             char (driver%get_model_name (1))
        write (u, "(1x,A,A)")  "md5sum        = ", &
             char (driver%get_md5sum (1))
        write (u, "(1x,A,L1)")  "openmp_status = ", driver%get_openmp_status (1)
        write (u, "(1x,A,I0)")  "n_in  = ", driver%get_n_in (1)
        write (u, "(1x,A,I0)")  "n_out = ", driver%get_n_out (1)
        write (u, "(1x,A,I0)")  "n_flv = ", driver%get_n_flv (1)
        write (u, "(1x,A,I0)")  "n_hel = ", driver%get_n_hel (1)
        write (u, "(1x,A,I0)")  "n_col = ", driver%get_n_col (1)
        write (u, "(1x,A,I0)")  "n_cin = ", driver%get_n_cin (1)
        write (u, "(1x,A,I0)")  "n_cf  = ", driver%get_n_cf (1)
 
        call driver%set_flv_state (1, flv_state)
        write (u, "(1x,A,10(1x,I0))")  "flv_state =", flv_state
 
        call driver%set_hel_state (1, hel_state)
        write (u, "(1x,A,10(1x,I0))")  "hel_state =", hel_state
 
        call driver%set_col_state (1, col_state, ghost_flag)
        write (u, "(1x,A,10(1x,I0))")  "col_state =", col_state
        write (u, "(1x,A,10(1x,L1))")  "ghost_flag =", ghost_flag
 
        call driver%set_color_factors (1, color_factors, cf_index)
        write (u, "(1x,A,10(1x,F5.3))")  "color_factors =", color_factors
        write (u, "(1x,A,10(1x,I0))")  "cf_index =", cf_index
 
        call driver%get_fptr (1, 1, proc1_ptr)
        call c_f_procpointer (proc1_ptr, proc1)
        if (associated (proc1)) then
           write (u, *)
           call proc1 (n)
           write (u, "(1x,A,I0)")  "proc1(1) = ", n
        end if
 
     end if
 
     deallocate (test_writer_6)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prclib_interfaces_6"
   end subroutine prclib_interfaces_6
 
 @ %def prclib_interfaces_6
 @ This version of test-code writer writes interfaces for all standard
 features plus one specific feature.  The interfaces are all bind(C),
 so no wrapper is needed.
 
 The driver part is identical to the Fortran case, so we simply extend
 the previous [[test_writer_5]] type.  We only have to override the
 Makefile writer.
 <<Prclib interfaces: test types>>=
   type, extends (test_writer_5_t) :: test_writer_6_t
    contains
      procedure, nopass :: type_name => test_writer_6_type_name
      procedure :: write_makefile_code => test_writer_6_mk
      procedure :: write_source_code => test_writer_6_src
   end type test_writer_6_t
 
 @ %def test_writer_6
 @
 <<Prclib interfaces: test auxiliary>>=
   function test_writer_6_type_name () result (string)
     type(string_t) :: string
     string = "test_6"
   end function test_writer_6_type_name
 
   subroutine test_writer_6_mk &
        (writer, unit, id, os_data, verbose, testflag)
     class(test_writer_6_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), ".c"
     write (unit, "(5A)")  "OBJECTS += ", char (id), ".lo"
     write (unit, "(5A)")  char (id), ".lo: ", char (id), ".c"
     if (.not. verbose) then
        write (unit, "(5A)")  TAB // '@echo  "  FC       " $@'
     end if    
     write (unit, "(5A)")  TAB, "$(LTCCOMPILE) $<"
   end subroutine test_writer_6_mk
 
   subroutine test_writer_6_src (writer, id)
     class(test_writer_6_t), intent(in) :: writer
     type(string_t), intent(in) :: id
     call write_test_c_lib_file (id, var_str ("proc1"))
   end subroutine test_writer_6_src
 
 @ %def test_writer_6_type_name test_writer_6_mk
 @
 We need a test module file (actually, one for each process in the test
 above) that allows us to check compilation and linking.  The test
 module implements a colorless $1\to 2$ process, and it implements one
 additional function (feature), the name given as an argument.
 <<Prclib interfaces: test auxiliary>>=
   subroutine write_test_c_lib_file (basename, feature)
     type(string_t), intent(in) :: basename
     type(string_t), intent(in) :: feature
     integer :: u
     u = free_unit ()
     open (u, file = char (basename) // ".c", &
          status = "replace", action = "write")
     write (u, "(A)")  "/* (Pseudo) matrix element code file &
          &for WHIZARD self-test */"
     write (u, "(A)")  "#include <stdbool.h>"
     if (CC_HAS_QUADMATH) then
        write (u, "(A)")  "#include <quadmath.h>"
     end if
     write (u, *)
     call write_test_me_code_4 (u, char (basename))
     write (u, *)
     write (u, "(A)")  "void " // char (basename) // "_" &
          // char (feature) // "(int* n) {"
     write (u, "(A)")  "  *n = 42;"
     write (u, "(A)")  "}"
     close (u)
   end subroutine write_test_c_lib_file
 
 @ %def write_test_module_file
 @
 The following matrix-element source code is equivalent to the code in
 the previous example, but coded in C.
 <<Prclib interfaces: test auxiliary>>=
   subroutine write_test_me_code_4 (u, id)
     integer, intent(in) :: u
     character(*), intent(in) :: id
     write (u, "(A)")  "char* " // id // "_get_md5sum() {"
     write (u, "(A)")  "  return ""1234567890abcdef1234567890abcdef"";"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "bool " // id // "_openmp_supported() {"
     write (u, "(A)")  "  return false;"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "int " // id // "_n_in() {"
     write (u, "(A)")  "  return 1;"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "int " // id // "_n_out() {"
     write (u, "(A)")  "  return 2;"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "int " // id // "_n_flv() {"
     write (u, "(A)")  "  return 1;"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "int " // id // "_n_hel() {"
     write (u, "(A)")  "  return 1;"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "int " // id // "_n_cin() {"
     write (u, "(A)")  "  return 2;"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "int " // id // "_n_col() {"
     write (u, "(A)")  "  return 1;"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "int " // id // "_n_cf() {"
     write (u, "(A)")  "  return 1;"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "void " // id // "_flv_state( int (*a)[] ) {"
     write (u, "(A)")  "  static int flv_state[1][3] =  { { 1, 2, 3 } };"
     write (u, "(A)")  "  int j;"
     write (u, "(A)")  "  for (j = 0; j < 3; j++) { (*a)[j] &
          &= flv_state[0][j]; }"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "void " // id // "_hel_state( int (*a)[] ) {"
     write (u, "(A)")  "  static int hel_state[1][3] =  { { 0, 0, 0 } };"
     write (u, "(A)")  "  int j;"
     write (u, "(A)")  "  for (j = 0; j < 3; j++) { (*a)[j] &
          &= hel_state[0][j]; }"
     write (u, "(A)")  "}"
     write (u, *)
     write (u, "(A)")  "void " // id // "_col_state&
          &( int (*a)[], bool (*g)[] ) {"
     write (u, "(A)")  "  static int col_state[1][3][2] = &
          &{ { {0, 0}, {0, 0}, {0, 0} } };"
     write (u, "(A)")  "  static bool ghost_flag[1][3] =  &
          &{ { false, false, false } };"
     write (u, "(A)")  "  int j,k;"
     write (u, "(A)")  "  for (j = 0; j < 3; j++) {"
     write (u, "(A)")  "    for (k = 0; k < 2; k++) {"
     write (u, "(A)")  "       (*a)[j*2+k] = col_state[0][j][k];"
     write (u, "(A)")  "    }"
     write (u, "(A)")  "    (*g)[j] = ghost_flag[0][j];"
     write (u, "(A)")  "  }"
     write (u, "(A)")  "}"
     write (u, *)
     select case (DEFAULT_FC_PRECISION)
     case ("quadruple")
        write (u, "(A)")  "void " // id // "_color_factors&
             &( int (*cf_index1)[], int (*cf_index2)[], &
             &__complex128 (*color_factors)[] ) {"
     case ("extended")
        write (u, "(A)")  "void " // id // "_color_factors&
             &( int (*cf_index1)[], int (*cf_index2)[], &
             &long double _Complex (*color_factors)[] ) {"
     case default
        write (u, "(A)")  "void " // id // "_color_factors&
             &( int (*cf_index1)[], int (*cf_index2)[], &
             &double _Complex (*color_factors)[] ) {"
     end select
     write (u, "(A)")  "  (*color_factors)[0] = 1;"
     write (u, "(A)")  "  (*cf_index1)[0] = 1;"
     write (u, "(A)")  "  (*cf_index2)[0] = 1;"
     write (u, "(A)")  "}"
   end subroutine write_test_me_code_4
 
 @ %def write_test_me_code_4
 @
 \subsubsection{Test cleanup targets}
 Test 7: Repeat test 4 (create, compile, link Fortran module and
 driver) and properly clean up all generated files.
 <<Prclib interfaces: execute tests>>=
   call test (prclib_interfaces_7, "prclib_interfaces_7", &
        "cleanup", &
        u, results)
 <<Prclib interfaces: test declarations>>=
   public :: prclib_interfaces_7
 <<Prclib interfaces: tests>>=
   subroutine prclib_interfaces_7 (u)
     integer, intent(in) :: u
     class(prclib_driver_t), allocatable :: driver
     class(prc_writer_t), pointer :: test_writer_4
     type(os_data_t) :: os_data
     integer :: u_file
     character(32), parameter :: md5sum = "1234567890abcdef1234567890abcdef"
 
     write (u, "(A)")  "* Test output: prclib_interfaces_7"
     write (u, "(A)")  "*   Purpose: compile and link process library"
     write (u, "(A)")  "*            with (fake) matrix-element code &
          &as a Fortran module"
     write (u, "(A)")  "*            then clean up generated files"
     write (u, *)
     write (u, "(A)")  "* Create a prclib driver object (1 process)"
 
     allocate (test_writer_4_t :: test_writer_4)
 
     call os_data%init ()
     call dispatch_prclib_driver (driver, var_str ("prclib7"), var_str (""))
     call driver%init (1)
     call driver%set_md5sum (md5sum)
     call driver%set_record (1, var_str ("test7"), var_str ("Test_model"), &
          [var_str ("proc1")], test_writer_4)
 
     write (u, "(A)")  "* Write makefile"
     u_file = free_unit ()
     open (u_file, file="prclib7.makefile", status="replace", action="write")
     call driver%generate_makefile (u_file, os_data, verbose = .false.)
     close (u_file)
 
     write (u, "(A)")  "* Write driver source code"
     u_file = free_unit ()
     open (u_file, file="prclib7.f90", status="replace", action="write")
     call driver%generate_driver_code (u_file)
     close (u_file)
 
     write (u, "(A)")  "* Write matrix-element source code"
     call driver%make_source (os_data)
 
     write (u, "(A)")  "* Compile source code"
     call driver%make_compile (os_data)
 
     write (u, "(A)")  "* Link library"
     call driver%make_link (os_data)
 
 
     write (u, "(A)")  "* File check"
     write (u, *)
     call check_file (u, "test7.f90")
     call check_file (u, "tpr_test7.mod")
     call check_file (u, "test7.lo")
     call check_file (u, "prclib7.makefile")
     call check_file (u, "prclib7.f90")
     call check_file (u, "prclib7.lo")
     call check_file (u, "prclib7.la")
 
     write (u, *)
     write (u, "(A)")  "* Delete library"
     write (u, *)
     call driver%clean_library (os_data)
     call check_file (u, "prclib7.la")
 
     write (u, *)
     write (u, "(A)")  "* Delete object code"
     write (u, *)
     call driver%clean_objects (os_data)
     call check_file (u, "test7.lo")
     call check_file (u, "tpr_test7.mod")
     call check_file (u, "prclib7.lo")
 
     write (u, *)
     write (u, "(A)")  "* Delete source code"
     write (u, *)
     call driver%clean_source (os_data)
     call check_file (u, "test7.f90")
 
     write (u, *)
     write (u, "(A)")  "* Delete driver source code"
     write (u, *)
     call driver%clean_driver (os_data)
     call check_file (u, "prclib7.f90")
 
     write (u, *)
     write (u, "(A)")  "* Delete makefile"
     write (u, *)
     call driver%clean_makefile (os_data)
     call check_file (u, "prclib7.makefile")
 
     deallocate (test_writer_4)
 
     write (u, *)
     write (u, "(A)")  "* Test output end: prclib_interfaces_7"
   end subroutine prclib_interfaces_7
 
 @ %def prclib_interfaces_7
 @ Auxiliary routine: check and report existence of a file
 <<Prclib interfaces: test auxiliary>>=
   subroutine check_file (u, file)
     integer, intent(in) :: u
     character(*), intent(in) :: file
     logical :: exist
     inquire (file=file, exist=exist)
     write (u, "(2x,A,A,L1)")  file, " = ", exist
   end subroutine check_file
 
 @ %def check_file
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Abstract process core configuration}
 In this module, we define abstract data types that handle the method-specific
 part of defining a process (including all of its options) and accessing an
 external matrix element.
 
 There are no unit tests, these are deferred to the [[process_libraries]]
 module below.
 <<[[prc_core_def.f90]]>>=
 <<File header>>
 
 module prc_core_def
 
 <<Use strings>>
   use io_units
   use diagnostics
 
   use process_constants
   use prclib_interfaces
 
 <<Standard module head>>
 
 <<Prc core def: public>>
 
 <<Prc core def: types>>
 
 <<Prc core def: interfaces>>
 
 contains
 
 <<Prc core def: procedures>>
 
 end module prc_core_def
 @ %def prc_core_def
 @
 \subsection{Process core definition type}
 For storing configuration data that depend on the specific process
 variant, we introduce a polymorphic type.  At this point, we just
 declare an abstract base type.  This allows us to defer the
 implementation to later modules.
 
 There should be no components that need explicit finalization,
 otherwise we would have to call a finalizer from the
 [[process_component_def_t]] wrapper.
 
 @ Translate a [[prc_core_def_t]] to above named integers
 <<Prc core def: public>>=
   public :: prc_core_def_t
 <<Prc core def: types>>=
   type, abstract :: prc_core_def_t
      class(prc_writer_t), allocatable :: writer
    contains
    <<Prc core def: process core def: TBP>>
   end type prc_core_def_t
 
 @ %def prc_core_def_t
 @ Interfaces for the deferred methods.
 
 This returns a string.  No passed argument; the string is constant and
 depends just on the type.
 <<Prc core def: process core def: TBP>>=
   procedure (prc_core_def_get_string), nopass, deferred :: type_string
 <<Prc core def: interfaces>>=
   abstract interface
      function prc_core_def_get_string () result (string)
        import
        type(string_t) :: string
      end function prc_core_def_get_string
   end interface
 
 @ %def prc_core_def_get_string
 @
 The [[write]] method should
 display the content completely.
 <<Prc core def: process core def: TBP>>=
   procedure (prc_core_def_write), deferred :: write
 <<Prc core def: interfaces>>=
   abstract interface
      subroutine prc_core_def_write (object, unit)
        import
        class(prc_core_def_t), intent(in) :: object
        integer, intent(in) :: unit
      end subroutine prc_core_def_write
   end interface
 
 @ %def prc_core_def_write
 @
 The [[read]] method should
 fill the content completely.
 <<Prc core def: process core def: TBP>>=
   procedure (prc_core_def_read), deferred :: read
 <<Prc core def: interfaces>>=
   abstract interface
      subroutine prc_core_def_read (object, unit)
        import
        class(prc_core_def_t), intent(out) :: object
        integer, intent(in) :: unit
      end subroutine prc_core_def_read
   end interface
 
 @ %def prc_core_def_read
 @ This communicates a MD5 checksum to the writer inside the [[core_def]]
 object, if there is any.  Usually, this checksum is not yet known at the time
 when the writer is initialized.
 <<Prc core def: process core def: TBP>>=
   procedure :: set_md5sum => prc_core_def_set_md5sum
 <<Prc core def: procedures>>=
   subroutine prc_core_def_set_md5sum (core_def, md5sum)
     class(prc_core_def_t), intent(inout) :: core_def
     character(32) :: md5sum
     if (allocated (core_def%writer))  core_def%writer%md5sum = md5sum
   end subroutine prc_core_def_set_md5sum
 
 @ %def prc_core_def_set_md5sum
 @ Allocate an appropriate driver object which corresponds to the
 chosen process core definition.
 
 For internal matrix element (i.e., those which do not need external
 code), the driver should have access to all matrix element information
 from the beginning.  In short, it is the matrix-element code.
 
 For external matrix elements, the driver will get access to the
 external matrix element code.
 <<Prc core def: process core def: TBP>>=
   procedure(prc_core_def_allocate_driver), deferred :: allocate_driver
 <<Prc core def: interfaces>>=
   abstract interface
      subroutine prc_core_def_allocate_driver (object, driver, basename)
        import
        class(prc_core_def_t), intent(in) :: object
        class(prc_core_driver_t), intent(out), allocatable :: driver
        type(string_t), intent(in) :: basename
      end subroutine prc_core_def_allocate_driver
   end interface
 
 @ %def prc_core_def_allocate_driver
 @ This flag tells whether the particular variant needs external code.
 We implement a default function which returns false.  The flag
 depends only on the type, therefore we implement it as [[nopass]].
 <<Prc core def: process core def: TBP>>=
   procedure, nopass :: needs_code => prc_core_def_needs_code
 <<Prc core def: procedures>>=
   function prc_core_def_needs_code () result (flag)
     logical :: flag
     flag = .false.
   end function prc_core_def_needs_code
 
 @ %def prc_core_def_needs_code
 @ This subroutine allocates an array which holds the name of all
 features that this process core implements.  This feature
 applies to matrix element code that is not coded as a Fortran module
 but communicates via independent library functions, which follow the C
 calling conventions.  The addresses of those functions are returned as
 C function pointers, which can be converted into Fortran procedure
 pointers.  The conversion is done in code specific for the process
 variant; here we just retrieve the C function pointer.
 
 The array returned here serves the purpose of writing specific
 driver code.  The driver interfaces only those C functions which are
 supported for the given process core.
 
 If the process core does not require external code, this array is
 meaningless.
 <<Prc core def: process core def: TBP>>=
   procedure(prc_core_def_get_features), nopass, deferred &
        :: get_features
 <<Prc core def: interfaces>>=
   abstract interface
      subroutine prc_core_def_get_features (features)
        import
        type(string_t), dimension(:), allocatable, intent(out) :: features
      end subroutine prc_core_def_get_features
   end interface
 
 @ %def prc_core_def_get_features
 @ Assign pointers to the process-specific procedures to the driver, if
 the process is external.
 <<Prc core def: process core def: TBP>>=
   procedure(prc_core_def_connect), deferred :: connect
 <<Prc core def: interfaces>>=
   abstract interface
      subroutine prc_core_def_connect (def, lib_driver, i, proc_driver)
        import
        class(prc_core_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
      end subroutine prc_core_def_connect
   end interface
 
 @ %def prc_core_def_connect
 @
 \subsection{Process core template}
 We must be able to automatically allocate a process core definition object
 with the appropriate type, given only the type name.
 
 To this end, we introduce a [[prc_template_t]] type which is simply a wrapper
 for an empty [[prc_core_def_t]] object.  Choosing one of the templates from an
 array, we can allocate the target object.
 <<Prc core def: public>>=
   public :: prc_template_t
 <<Prc core def: types>>=
   type :: prc_template_t
      class(prc_core_def_t), allocatable :: core_def
   end type prc_template_t
 
 @ %def prc_template_t
 @ The allocation routine.  We use the [[source]] option of the [[allocate]]
 statement.   The [[mold]] option would probably more appropriate, but is a
 F2008 feature.
 <<Prc core def: public>>=
   public :: allocate_core_def
 <<Prc core def: procedures>>=
   subroutine allocate_core_def (template, name, core_def)
     type(prc_template_t), dimension(:), intent(in) :: template
     type(string_t), intent(in) :: name
     class(prc_core_def_t), allocatable :: core_def
     integer :: i
     do i = 1, size (template)
        if (template(i)%core_def%type_string () == name) then
           allocate (core_def, source = template(i)%core_def)
           return
        end if
     end do
   end subroutine allocate_core_def
 
 @ %def allocate_core_def
 @
 \subsection{Process driver}
 For each process component, we implement a driver object which holds
 the calls to the matrix element and various auxiliary routines as
 procedure pointers.  Any actual calculation will use this object to
 communicate with the process.
 
 Depending on the type of process (as described by a corresponding
 [[prc_core_def]] object), the procedure pointers may refer to
 external or internal code, and there may be additional procedures for
 certain types.  The base type defined here is abstract.
 <<Prc core def: public>>=
   public :: prc_core_driver_t
 <<Prc core def: types>>=
   type, abstract :: prc_core_driver_t
    contains
    <<Prc core def: process driver: TBP>>
   end type prc_core_driver_t
 
 @ %def prc_core_driver_t
 @ This returns the process type.  No reference to contents.
 <<Prc core def: process driver: TBP>>=
   procedure(prc_core_driver_type_name), nopass, deferred :: type_name
 <<Prc core def: interfaces>>=
   abstract interface
      function prc_core_driver_type_name () result (type)
        import
        type(string_t) :: type
      end function prc_core_driver_type_name
   end interface
 
 @ %def prc_core_driver_type_name
 @
 \subsection{Process driver for intrinsic process}
 This is an abstract extension for the driver type.  It has one
 additional method, namely a subroutine that fills the record of
 constant process data.  For an external process, this task is
 performed by the external library driver instead.
 <<Prc core def: public>>=
   public :: process_driver_internal_t
 <<Prc core def: types>>=
   type, extends (prc_core_driver_t), abstract :: process_driver_internal_t
    contains
    <<Prc core def: process driver internal: TBP>>
   end type process_driver_internal_t
 
 @ %def process_driver_internal_t
 <<Prc core def: process driver internal: TBP>>=
   procedure(process_driver_fill_constants), deferred :: fill_constants
 <<Prc core def: interfaces>>=
   abstract interface
      subroutine process_driver_fill_constants (driver, data)
        import
        class(process_driver_internal_t), intent(in) :: driver
        type(process_constants_t), intent(out) :: data
      end subroutine process_driver_fill_constants
   end interface
 
 @ %def process_driver_fill_constants
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process library access}
 \label{sec:process_libraries}
 Processes (the code and data that are necessary for evaluating matrix
 elements of a particular process or process component) are organized
 in process libraries.  In full form, process libraries contain
 generated and dynamically compiled and linked code, so they are actual
 libraries on the OS level.  Alternatively, there may be simple
 processes that can be generated without referring to external
 libraries, and external libraries that are just linked in.
 
 This module interfaces the OS to create, build, and use process
 libraries.
 
 We work with two related data structures.  There is the list of
 process configurations that stores the user input and data derived
 from it.  A given process configuration list is scanned for creating a
 process library, which consists of both data and code.  The creation
 step involves calling external programs and incorporating external
 code.
 
 For the subsequent integration and event generation steps, we read the
 process library.  We also support partial (re)creation of the process
 library.  To this end, we should be able to reconstruct the
 configuration data records from the process library.
 <<[[process_libraries.f90]]>>=
 <<File header>>
 
 module process_libraries
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use strings>>
   use io_units
   use diagnostics
   use md5
   use physics_defs
   use os_interface
   use model_data
   use particle_specifiers
   use process_constants
   use prclib_interfaces
   use prc_core_def
 
 <<Standard module head>>
 
 <<Process libraries: public>>
 
 <<Process libraries: parameters>>
 
 <<Process libraries: types>>
 
 contains
 
 <<Process libraries: procedures>>
 
 end module process_libraries
 @ %def process_libraries
 @
 \subsection{Auxiliary stuff}
 Here is a small subroutine that strips the left-hand side and the
 equals sign off an equation.
 <<Process libraries: public>>=
   public :: strip_equation_lhs
 <<Process libraries: procedures>>=
   subroutine strip_equation_lhs (buffer)
     character(*), intent(inout) :: buffer
     type(string_t) :: string, prefix
     string = buffer
     call split (string, prefix, "=")
     buffer = string
   end subroutine strip_equation_lhs
 
 @ %def strip_equation_lhs
 @
 \subsection{Process definition objects}
 We collect process configuration data in a derived type,
 [[process_def_t]].  A process can be a collection of several
 components which are treated as a single entity for the purpose of
 observables and event generation.  Multiple process components may
 initially be defined by the user.  The system may add additional
 components, e.g., subtraction terms.  The common data type is
 [[process_component_def_t]].  Within each component, there are several
 universal data items, and a part which depend on the particular
 process variant.  The latter is covered by an abstract type
 [[prc_core_def_t]] and its extensions.
 
 @
 \subsubsection{Wrapper for components}
 We define a wrapper type for the configuration of individual
 components.
 
 The string [[basename]] is used for building file, module, and
 function names for the current process component.  Initially, it will
 be built from the corresponding process basename by appending an
 alphanumeric suffix.
 
 The logical [[initial]] tells whether this is a user-defined (true) or
 system-generated (false) configuration.
 
 The numbers [[n_in]], [[n_out]], and [[n_tot]] denote the incoming,
 outgoing and total number of particles (partons) participating in the
 process component, respectively.  These are the nominal particles, as
 input by the user (recombination may change the particle content, for
 the output events).
 
 The string arrays [[prt_in]] and [[prt_out]] hold the particle
 specifications as provided by the user.  For a system-generated
 process component, they remain deallocated.
 
 The [[method]] string is used to determine the type of process matrix
 element and how it is obtained.
 
 The [[description]] string collects the information about particle
 content and method in a single human-readable string.
 
 The pointer object [[core_def]] is allocated according to the
 actual process variant, which depends on the method.  The subobject
 holds any additional configuration data that is relevant for the
 process component.
 
 We assume that no finalizer is needed.
 <<Process libraries: public>>=
   public :: process_component_def_t
 <<Process libraries: types>>=
   type :: process_component_def_t
      private
      type(string_t) :: basename
      logical :: initial = .false.
      integer :: n_in = 0
      integer :: n_out = 0
      integer :: n_tot = 0
      type(prt_spec_t), dimension(:), allocatable :: prt_in
      type(prt_spec_t), dimension(:), allocatable :: prt_out
      type(string_t) :: method
      type(string_t) :: description
      class(prc_core_def_t), allocatable :: core_def
      character(32) :: md5sum = ""
      integer :: nlo_type = BORN
      integer, dimension(N_ASSOCIATED_COMPONENTS) :: associated_components = 0
      logical :: active
      integer :: fixed_emitter = -1
      integer :: alpha_power = 0
      integer :: alphas_power = 0
    contains
    <<Process libraries: process component def: TBP>>
   end type process_component_def_t
 
 @ %def process_component_def_t
 @ Display the complete content.
 <<Process libraries: process component def: TBP>>=
   procedure :: write => process_component_def_write
 <<Process libraries: procedures>>=
   subroutine process_component_def_write (object, unit)
     class(process_component_def_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A,A)")  "Component ID        = ", char (object%basename)
     write (u, "(3x,A,L1)") "Initial component   = ", object%initial
     write (u, "(3x,A,I0,1x,I0,1x,I0)") "N (in, out, tot)    = ", &
          object%n_in, object%n_out, object%n_tot
     write (u, "(3x,A)", advance="no") "Particle content    = "
     if (allocated (object%prt_in)) then
        call prt_spec_write (object%prt_in, u, advance="no")
     else
        write (u, "(A)", advance="no")  "[undefined]"
     end if
     write (u, "(A)", advance="no") " => "
     if (allocated (object%prt_out)) then
        call prt_spec_write (object%prt_out, u, advance="no")
     else
        write (u, "(A)", advance="no")  "[undefined]"
     end if
     write (u, "(A)")
     if (object%method /= "") then
        write (u, "(3x,A,A)")  "Method              = ", &
             char (object%method)
     else
        write (u, "(3x,A)")  "Method              = [undefined]"
     end if
     if (allocated (object%core_def)) then
        write (u, "(3x,A,A)")  "Process variant     = ", &
             char (object%core_def%type_string ())
        call object%core_def%write (u)
     else
        write (u, "(3x,A)")  "Process variant     = [undefined]"
     end if
     write (u, "(3x,A,A,A)") "MD5 sum (def)       = '", object%md5sum, "'"
   end subroutine process_component_def_write
 
 @ %def process_component_def_write
 @ Read the process component definition.  Allocate the process variant
 definition with appropriate type, matching the type name on file with
 the provided templates.
 <<Process libraries: process component def: TBP>>=
   procedure :: read => process_component_def_read
 <<Process libraries: procedures>>=
   subroutine process_component_def_read (component, unit, core_def_templates)
     class(process_component_def_t), intent(out) :: component
     integer, intent(in) :: unit
     type(prc_template_t), dimension(:), intent(in) :: core_def_templates
     character(80) :: buffer
     type(string_t) :: var_buffer, prefix, in_state, out_state
     type(string_t) :: variant_type
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     component%basename = trim (adjustl (buffer))
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     read (buffer, *)  component%initial
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     read (buffer, *)  component%n_in, component%n_out, component%n_tot
 
     call get (unit, var_buffer)
     call split (var_buffer, prefix, "=")   ! keeps 'in => out'
     call split (var_buffer, prefix, "=")   ! actually: separator is '=>'
 
     in_state = prefix
     if (component%n_in > 0) then
        call prt_spec_read (component%prt_in, in_state)
     end if
 
     out_state = extract (var_buffer, 2)
     if (component%n_out > 0) then
        call prt_spec_read (component%prt_out, out_state)
     end if
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     component%method = trim (adjustl (buffer))
     if (component%method == "[undefined]") &
          component%method = ""
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     variant_type = trim (adjustl (buffer))
     call allocate_core_def &
          (core_def_templates, variant_type, component%core_def)
     if (allocated (component%core_def)) then
        call component%core_def%read (unit)
     end if
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     read (buffer(3:34), "(A32)")  component%md5sum
 
   end subroutine process_component_def_read
 
 @ %def process_component_def_read
 @ Short account.
 <<Process libraries: process component def: TBP>>=
   procedure :: show => process_component_def_show
 <<Process libraries: procedures>>=
   subroutine process_component_def_show (object, unit)
     class(process_component_def_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(6x,A)", advance="no")  char (object%basename)
     if (.not. object%initial) &
          write (u, "('*')", advance="no")
     write (u, "(':',1x)", advance="no")
     if (allocated (object%prt_in)) then
        call prt_spec_write (object%prt_in, u, advance="no")
     else
        write (u, "(A)", advance="no")  "[undefined]"
     end if
     write (u, "(A)", advance="no") " => "
     if (allocated (object%prt_out)) then
        call prt_spec_write (object%prt_out, u, advance="no")
     else
        write (u, "(A)", advance="no")  "[undefined]"
     end if
     if (object%method /= "") then
        write (u, "(2x,'[',A,']')")  char (object%method)
     else
        write (u, *)
     end if
   end subroutine process_component_def_show
 
 @ %def process_component_def_show
 @ Compute the MD5 sum of a process component.  We reset the stored MD5
 sum to the empty string (so a previous value is not included in the
 calculation), the write a temporary file and calculate the MD5 sum of
 that file.
 
 This implies that all data that are displayed by the [[write]] method
 become part of the MD5 sum calculation.
 
 The [[model]] is not part of the object, but must be included in the MD5 sum.
 Otherwise, modifying the model and nothing else would not trigger remaking the
 process-component source.  Note that the model parameters may change later and
 therefore are not incorporated.
 
 After the MD5 sum of the component has been computed, we communicate it to the
 [[writer]] subobject of the specific [[core_def]] component.  Although these
 types are abstract, the MD5-related features are valid for the abstract
 types.
 <<Process libraries: process component def: TBP>>=
   procedure :: compute_md5sum => process_component_def_compute_md5sum
 <<Process libraries: procedures>>=
   subroutine process_component_def_compute_md5sum (component, model)
     class(process_component_def_t), intent(inout) :: component
     class(model_data_t), intent(in), optional, target :: model
     integer :: u
     component%md5sum = ""
     u = free_unit ()
     open (u, status = "scratch", action = "readwrite")
     if (present (model))  write (u, "(A32)")  model%get_md5sum ()
     call component%write (u)
     rewind (u)
     component%md5sum = md5sum (u)
     close (u)
     if (allocated (component%core_def)) then
        call component%core_def%set_md5sum (component%md5sum)
     end if
   end subroutine process_component_def_compute_md5sum
 
 @ %def process_component_def_compute_md5sum
 @
 <<Process libraries: process component def: TBP>>=
   procedure :: get_def_type_string => process_component_def_get_def_type_string
 <<Process libraries: procedures>>=
   function process_component_def_get_def_type_string (component) result (type_string)
     type(string_t) :: type_string
     class(process_component_def_t), intent(in) :: component
     type_string = component%core_def%type_string ()
   end function process_component_def_get_def_type_string
 
 @ %def process_component_def_get_def_type_string
 @ Allocate the process driver (with a suitable type) for a process
 component.  For internal processes, we may set all data already at
 this stage.
 <<Process libraries: process component def: TBP>>=
   procedure :: allocate_driver => process_component_def_allocate_driver
 <<Process libraries: procedures>>=
   subroutine process_component_def_allocate_driver (component, driver)
     class(process_component_def_t), intent(in) :: component
     class(prc_core_driver_t), intent(out), allocatable :: driver
     if (allocated (component%core_def)) then
        call component%core_def%allocate_driver (driver, component%basename)
     end if
   end subroutine process_component_def_allocate_driver
 
 @ %def process_component_def_allocate_driver
 @ Tell whether the process core needs external code.
 <<Process libraries: process component def: TBP>>=
   procedure :: needs_code => process_component_def_needs_code
 <<Process libraries: procedures>>=
   function process_component_def_needs_code (component) result (flag)
     class(process_component_def_t), intent(in) :: component
     logical :: flag
     flag = component%core_def%needs_code ()
   end function process_component_def_needs_code
 
 @ %def process_component_def_needs_code
 @ If there is external code, the [[core_def]] subobject should
 provide a writer object.  This method returns a pointer to the writer.
 <<Process libraries: process component def: TBP>>=
   procedure :: get_writer_ptr => process_component_def_get_writer_ptr
 <<Process libraries: procedures>>=
   function process_component_def_get_writer_ptr (component) result (writer)
     class(process_component_def_t), intent(in), target :: component
     class(prc_writer_t), pointer :: writer
     writer => component%core_def%writer
   end function process_component_def_get_writer_ptr
 
 @ %def process_component_def_get_writer_ptr
 @ Return an array which holds the names of all C functions that this
 process component implements.
 <<Process libraries: process component def: TBP>>=
   procedure :: get_features => process_component_def_get_features
 <<Process libraries: procedures>>=
   function process_component_def_get_features (component) result (features)
     class(process_component_def_t), intent(in) :: component
     type(string_t), dimension(:), allocatable :: features
     call component%core_def%get_features (features)
   end function process_component_def_get_features
 
 @ %def process_component_def_get_features
 @ Assign procedure pointers in the [[driver]] component (external
 processes).  For internal processes, this is meaningless.
 <<Process libraries: process component def: TBP>>=
   procedure :: connect => process_component_def_connect
 <<Process libraries: procedures>>=
   subroutine process_component_def_connect &
        (component, lib_driver, i, proc_driver)
     class(process_component_def_t), intent(in) :: component
     class(prclib_driver_t), intent(in) :: lib_driver
     integer, intent(in) :: i
     class(prc_core_driver_t), intent(inout) :: proc_driver
     select type (proc_driver)
     class is (process_driver_internal_t)
        !!! Nothing to do
     class default
        call component%core_def%connect (lib_driver, i, proc_driver)
     end select
   end subroutine process_component_def_connect
 
 @ %def process_component_def_connect
 @ Return a pointer to the process core definition, which is of
 abstract type.
 <<Process libraries: process component def: TBP>>=
   procedure :: get_core_def_ptr => process_component_get_core_def_ptr
 <<Process libraries: procedures>>=
   function process_component_get_core_def_ptr (component) result (ptr)
     class(process_component_def_t), intent(in), target :: component
     class(prc_core_def_t), pointer :: ptr
     ptr => component%core_def
   end function process_component_get_core_def_ptr
 
 @ %def process_component_get_core_def_ptr
 @ Return nominal particle counts, as input by the user.
 <<Process libraries: process component def: TBP>>=
   procedure :: get_n_in  => process_component_def_get_n_in
   procedure :: get_n_out => process_component_def_get_n_out
   procedure :: get_n_tot => process_component_def_get_n_tot
 <<Process libraries: procedures>>=
   function process_component_def_get_n_in (component) result (n_in)
     class(process_component_def_t), intent(in) :: component
     integer :: n_in
     n_in = component%n_in
   end function process_component_def_get_n_in
 
   function process_component_def_get_n_out (component) result (n_out)
     class(process_component_def_t), intent(in) :: component
     integer :: n_out
     n_out = component%n_out
   end function process_component_def_get_n_out
 
   function process_component_def_get_n_tot (component) result (n_tot)
     class(process_component_def_t), intent(in) :: component
     integer :: n_tot
     n_tot = component%n_tot
   end function process_component_def_get_n_tot
 
 @ %def process_component_def_get_n_in
 @ %def process_component_def_get_n_out
 @ %def process_component_def_get_n_tot
 @ Allocate and return string arrays for the incoming and outgoing particles.
 <<Process libraries: process component def: TBP>>=
   procedure :: get_prt_in => process_component_def_get_prt_in
   procedure :: get_prt_out => process_component_def_get_prt_out
 <<Process libraries: procedures>>=
   subroutine process_component_def_get_prt_in (component, prt)
     class(process_component_def_t), intent(in) :: component
     type(string_t), dimension(:), intent(out), allocatable :: prt
     integer :: i
     allocate (prt (component%n_in))
     do i = 1, component%n_in
        prt(i) = component%prt_in(i)%to_string ()
     end do
   end subroutine process_component_def_get_prt_in
 
   subroutine process_component_def_get_prt_out (component, prt)
     class(process_component_def_t), intent(in) :: component
     type(string_t), dimension(:), intent(out), allocatable :: prt
     integer :: i
     allocate (prt (component%n_out))
     do i = 1, component%n_out
        prt(i) = component%prt_out(i)%to_string ()
     end do
   end subroutine process_component_def_get_prt_out
 
 @ %def process_component_def_get_prt_in
 @ %def process_component_def_get_prt_out
 @ Return the incoming and outgoing particle specifiers as-is.
 <<Process libraries: process component def: TBP>>=
   procedure :: get_prt_spec_in => process_component_def_get_prt_spec_in
   procedure :: get_prt_spec_out => process_component_def_get_prt_spec_out
 <<Process libraries: procedures>>=
   function process_component_def_get_prt_spec_in (component) result (prt)
     class(process_component_def_t), intent(in) :: component
     type(prt_spec_t), dimension(:), allocatable :: prt
     allocate (prt (component%n_in))
     prt(:) = component%prt_in(:)
   end function process_component_def_get_prt_spec_in
 
   function process_component_def_get_prt_spec_out (component) result (prt)
     class(process_component_def_t), intent(in) :: component
     type(prt_spec_t), dimension(:), allocatable :: prt
     allocate (prt (component%n_out))
     prt(:) = component%prt_out(:)
   end function process_component_def_get_prt_spec_out
 
 @ %def process_component_def_get_prt_spec_in
 @ %def process_component_def_get_prt_spec_out
 @ Return the combination of incoming particles as a PDG code
 <<Process libraries: process component def: TBP>>=
   procedure :: get_pdg_in => process_component_def_get_pdg_in
 <<Process libraries: procedures>>=
   subroutine process_component_def_get_pdg_in (component, model, pdg)
     class(process_component_def_t), intent(in) :: component
     class(model_data_t), intent(in), target :: model
     integer, intent(out), dimension(:) :: pdg
     integer :: i
     do i = 1, size (pdg)
        pdg(i) = model%get_pdg (component%prt_in(i)%to_string ())
     end do
   end subroutine process_component_def_get_pdg_in
 
 @ %def process_component_def_get_pdg_in
 @ Return the MD5 sum.
 <<Process libraries: process component def: TBP>>=
   procedure :: get_md5sum => process_component_def_get_md5sum
 <<Process libraries: procedures>>=
   pure function process_component_def_get_md5sum (component) result (md5sum)
     class(process_component_def_t), intent(in) :: component
     character(32) :: md5sum
     md5sum = component%md5sum
   end function process_component_def_get_md5sum
 
 @ %def process_component_def_get_md5sum
 @ Get NLO data
 <<Process libraries: process component def: TBP>>=
   procedure :: get_nlo_type => process_component_def_get_nlo_type
   procedure :: get_associated_born &
        => process_component_def_get_associated_born
   procedure :: get_associated_real_fin &
        => process_component_def_get_associated_real_fin
   procedure :: get_associated_real_sing &
        => process_component_def_get_associated_real_sing
   procedure :: get_associated_subtraction &
        => process_component_def_get_associated_subtraction
   procedure :: get_association_list &
        => process_component_def_get_association_list
   procedure :: can_be_integrated &
        => process_component_def_can_be_integrated
   procedure :: get_associated_real => process_component_def_get_associated_real
 <<Process libraries: procedures>>=
   elemental function process_component_def_get_nlo_type (component) result (nlo_type)
     integer :: nlo_type
     class(process_component_def_t), intent(in) :: component
     nlo_type = component%nlo_type
   end function process_component_def_get_nlo_type
 
   elemental function process_component_def_get_associated_born (component) result (i_born)
     integer :: i_born
     class(process_component_def_t), intent(in) :: component
     i_born = component%associated_components(ASSOCIATED_BORN)
   end function process_component_def_get_associated_born
 
   elemental function process_component_def_get_associated_real_fin (component) result (i_rfin)
     integer :: i_rfin
     class(process_component_def_t), intent(in) :: component
     i_rfin = component%associated_components(ASSOCIATED_REAL_FIN)
   end function process_component_def_get_associated_real_fin
 
   elemental function process_component_def_get_associated_real_sing (component) result (i_rsing)
     integer :: i_rsing
     class(process_component_def_t), intent(in) :: component
     i_rsing = component%associated_components(ASSOCIATED_REAL_SING)
   end function process_component_def_get_associated_real_sing
 
   elemental function process_component_def_get_associated_subtraction (component) result (i_sub)
     integer :: i_sub
     class(process_component_def_t), intent(in) :: component
     i_sub = component%associated_components(ASSOCIATED_SUB)
   end function process_component_def_get_associated_subtraction
 
   elemental function process_component_def_can_be_integrated (component) result (active)
     logical :: active
     class(process_component_def_t), intent(in) :: component
     active = component%active
   end function process_component_def_can_be_integrated
 
   function process_component_def_get_association_list (component, i_skip_in) result (list)
     integer, dimension(:), allocatable :: list
     class(process_component_def_t), intent(in) :: component
     integer, intent(in), optional :: i_skip_in
     integer :: i, j, n, i_skip
     logical :: valid
     i_skip = 0; if (present (i_skip_in)) i_skip = i_skip_in
     n = count (component%associated_components /= 0) - 1
     if (i_skip > 0) n = n - 1
     allocate (list (n))
     j = 1
     do i = 1, size(component%associated_components)
        valid = component%associated_components(i) /= 0 &
                .and. i /= ASSOCIATED_SUB .and. i /= i_skip
        if (valid) then
           list(j) = component%associated_components(i)
           j = j + 1
        end if
     end do
   end function process_component_def_get_association_list
 
   function process_component_def_get_associated_real (component) result (i_real)
     integer :: i_real
     class(process_component_def_t), intent(in) :: component
     i_real = component%associated_components(ASSOCIATED_REAL)
   end function process_component_def_get_associated_real
 
 @ %def process_component_def_get_nlo_type, process_component_def_get_associated_born
 @ %def process_component_def_can_be_integrated
 @ %def process_component_def_get_association_list
 @ %def process_component_def_get_associated_real
 @ %def process_component_def_get_associated_real_fin
 @ %def process_component_def_get_associated_subtraction
 @
 <<Process libraries: process component def: TBP>>=
   procedure :: get_me_method => process_component_def_get_me_method
 <<Process libraries: procedures>>=
   elemental function process_component_def_get_me_method (component) result (method)
     type(string_t) :: method
     class(process_component_def_t), intent(in) :: component
     method = component%method
   end function process_component_def_get_me_method
 
 @ %def process_component_def_get_me_method
 @
 <<Process libraries: process component def: TBP>>=
   procedure :: get_fixed_emitter => process_component_def_get_fixed_emitter
 <<Process libraries: procedures>>=
   function process_component_def_get_fixed_emitter (component) result (emitter)
      integer :: emitter
      class(process_component_def_t), intent(in) :: component
      emitter = component%fixed_emitter
   end function process_component_def_get_fixed_emitter
 
 @ %def process_component_def_get_fixed_emitter
 @
 <<Process libraries: process component def: TBP>>=
   procedure :: get_coupling_powers => process_component_def_get_coupling_powers
 <<Process libraries: procedures>>=
   pure subroutine process_component_def_get_coupling_powers (component, alpha_power, alphas_power)
     class(process_component_def_t), intent(in) :: component
     integer, intent(out) :: alpha_power, alphas_power
     alpha_power = component%alpha_power
     alphas_power = component%alphas_power
   end subroutine process_component_def_get_coupling_powers
 
 @ %def process_component_def_get_coupling_powers
 @
 \subsubsection{Process definition}
 The process component definitions are collected in a common process
 definition object.
 
 The [[id]] is the ID string that the user has provided for identifying
 this process.  It must be a string that is allowed as part of a
 Fortran variable name, since it may be used for generating code.
 
 The number [[n_in]] is 1 or 2 for a decay or scattering process,
 respectively.  This must be identical to [[n_in]] for all components.
 
 The initial and extra component definitions (see above) are allocated as the
 [[initial]] and [[extra]] arrays, respectively.  The latter
 are determined from the former.
 
 The [[md5sum]] is used to verify the integrity of the configuration.
 <<Process libraries: public>>=
   public :: process_def_t
 <<Process libraries: types>>=
   type :: process_def_t
      private
      type(string_t) :: id
      integer :: num_id = 0
      class(model_data_t), pointer :: model => null ()
      type(string_t) :: model_name
      integer :: n_in  = 0
      integer :: n_initial = 0
      integer :: n_extra = 0
      type(process_component_def_t), dimension(:), allocatable :: initial
      type(process_component_def_t), dimension(:), allocatable :: extra
      character(32) :: md5sum = ""
      logical :: nlo_process = .false.
      logical :: requires_resonances = .false.
    contains
    <<Process libraries: process def: TBP>>
   end type process_def_t
 
 @ %def process_def_t
 @ Write the process definition including components:
 <<Process libraries: process def: TBP>>=
   procedure :: write => process_def_write
 <<Process libraries: procedures>>=
   subroutine process_def_write (object, unit)
     class(process_def_t), intent(in) :: object
     integer, intent(in) :: unit
     integer :: i
     write (unit, "(1x,A,A,A)") "ID = '", char (object%id), "'"
     if (object%num_id /= 0) &
          write (unit, "(1x,A,I0)")  "ID(num) = ", object%num_id
     select case (object%n_in)
     case (1);  write (unit, "(1x,A)")  "Decay"
     case (2);  write (unit, "(1x,A)")  "Scattering"
     case default
        write (unit, "(1x,A)")  "[Undefined process]"
        return
     end select
     if (object%model_name /= "") then
        write (unit, "(1x,A,A)")  "Model = ", char (object%model_name)
     else
        write (unit, "(1x,A)")  "Model = [undefined]"
     end if
     write (unit, "(1x,A,I0)")  "Initially defined component(s) = ", &
          object%n_initial
     write (unit, "(1x,A,I0)")  "Extra generated component(s)   = ", &
          object%n_extra
     if (object%requires_resonances) then
        ! This line has to matched with the reader below!
        write (unit, "(1x,A,I0)")  "Resonant subprocesses required"
     end if
     write (unit, "(1x,A,A,A)") "MD5 sum   = '", object%md5sum, "'"
     if (allocated (object%initial)) then
        do i = 1, size (object%initial)
           write (unit, "(1x,A,I0)")  "Component #", i
           call object%initial(i)%write (unit)
        end do
     end if
     if (allocated (object%extra)) then
        do i = 1, size (object%extra)
           write (unit, "(1x,A,I0)")  "Component #", object%n_initial + i
           call object%extra(i)%write (unit)
        end do
     end if
   end subroutine process_def_write
 
 @ %def process_def_write
 @ Read the process definition including components.
 <<Process libraries: process def: TBP>>=
   procedure :: read => process_def_read
 <<Process libraries: procedures>>=
   subroutine process_def_read (object, unit, core_def_templates)
     class(process_def_t), intent(out) :: object
     integer, intent(in) :: unit
     type(prc_template_t), dimension(:), intent(in) :: core_def_templates
     integer :: i, i1, i2
     character(80) :: buffer, ref
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     i1 = scan (buffer, "'")
     i2 = scan (buffer, "'", back=.true.)
     if (i2 > i1) then
        object%id = buffer(i1+1:i2-1)
     else
        object%id = ""
     end if
 
     read (unit, "(A)")  buffer
     select case (buffer(2:11))
     case ("Decay     "); object%n_in = 1
     case ("Scattering"); object%n_in = 2
     case default
        return
     end select
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     object%model_name = trim (adjustl (buffer))
     if (object%model_name == "[undefined]")  object%model_name = ""
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     read (buffer, *)  object%n_initial
 
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     read (buffer, *)  object%n_extra
 
     read (unit, "(A)")  buffer
     if (buffer(1:9) == " Resonant") then
        object%requires_resonances = .true.
        read (unit, "(A)")  buffer
     else
        object%requires_resonances = .false.
     end if
 
     call strip_equation_lhs (buffer)
     read (buffer(3:34), "(A32)")  object%md5sum
 
     if (object%n_initial > 0) then
        allocate (object%initial (object%n_initial))
        do i = 1, object%n_initial
           read (unit, "(A)")  buffer
           write (ref, "(1x,A,I0)")  "Component #", i
           if (buffer /= ref)  return                ! Wrong component header
           call object%initial(i)%read (unit, core_def_templates)
        end do
     end if
 
   end subroutine process_def_read
 
 @ %def process_def_read
 @ Short account.
 <<Process libraries: process def: TBP>>=
   procedure :: show => process_def_show
 <<Process libraries: procedures>>=
   subroutine process_def_show (object, unit)
     class(process_def_t), intent(in) :: object
     integer, intent(in) :: unit
     integer :: i
     write (unit, "(4x,A)", advance="no") char (object%id)
     if (object%num_id /= 0) &
          write (unit, "(1x,'(',I0,')')", advance="no")  object%num_id
     if (object%model_name /= "") &
          write (unit, "(1x,'[',A,']')", advance="no")  char (object%model_name)
     if (object%requires_resonances) then
        write (unit, "(1x,A)", advance="no")  "[+ resonant subprocesses]"
     end if
     write (unit, *)
     if (allocated (object%initial)) then
        do i = 1, size (object%initial)
           call object%initial(i)%show (unit)
        end do
     end if
     if (allocated (object%extra)) then
        do i = 1, size (object%extra)
           call object%extra(i)%show (unit)
        end do
     end if
   end subroutine process_def_show
 
 @ %def process_def_show
 @ Initialize an entry (initialize the process definition inside).  We
 allocate the 'initial' set of components.  Extra components remain
 unallocated.
 
 The model should be present as a pointer.  This allows us to retrieve the
 model's MD5 sum.  However, for various tests it is sufficient to have the
 name.
 
 We create the basenames for the process components by appending a
 suffix which we increment for each component.
 <<Process libraries: process def: TBP>>=
   procedure :: init => process_def_init
 <<Process libraries: procedures>>=
   subroutine process_def_init (def, id, &
        model, model_name, n_in, n_components, num_id, &
        nlo_process, requires_resonances)
     class(process_def_t), intent(out) :: def
     type(string_t), intent(in), optional :: id
     class(model_data_t), intent(in), optional, target :: model
     type(string_t), intent(in), optional :: model_name
     integer, intent(in), optional :: n_in
     integer, intent(in), optional :: n_components
     integer, intent(in), optional :: num_id
     logical, intent(in), optional :: nlo_process
     logical, intent(in), optional :: requires_resonances
     character(16) :: suffix
     integer :: i
     if (present (id)) then
        def%id = id
     else
        def%id = ""
     end if
     if (present (num_id)) then
        def%num_id = num_id
     end if
     if (present (model)) then
        def%model => model
        def%model_name = model%get_name ()
     else
        def%model => null ()
        if (present (model_name)) then
           def%model_name = model_name
        else
           def%model_name = ""
        end if
     end if
     if (present (n_in))  def%n_in = n_in
     if (present (n_components)) then
        def%n_initial = n_components
        allocate (def%initial (n_components))
     end if
     if (present (nlo_process)) then
        def%nlo_process = nlo_process
     end if
     if (present (requires_resonances)) then
        def%requires_resonances = requires_resonances
     end if
     def%initial%initial = .true.
     def%initial%method     = ""
     do i = 1, def%n_initial
        write (suffix, "(A,I0)")  "_i", i
        def%initial(i)%basename = def%id // trim (suffix)
     end do
     def%initial%description = ""
   end subroutine process_def_init
 
 @ %def process_def_init
 @ Explicitly set the model name (for unit test).
 <<Process libraries: process def: TBP>>=
   procedure :: set_model_name => process_def_set_model_name
 <<Process libraries: procedures>>=
   subroutine process_def_set_model_name (def, model_name)
     class(process_def_t), intent(inout) :: def
     type(string_t), intent(in) :: model_name
     def%model_name = model_name
   end subroutine process_def_set_model_name
 
 @ %def process_def_set_model_name
 @ Initialize an initial component.  The particle content
 must be specified.  The process core block is not (yet) allocated.
 
 We assume that the particle arrays match the [[n_in]] and
 [[n_out]] values in size.  The model is referred to by name; it is
 identified as an existing model later.  The index [[i]] must refer to
 an existing element of the component array.
 
 Data specific for the process core of a component are imported as
 the [[core_def]] argument.  We should allocate an object of class
 [[prc_core_def_t]] with the appropriate specific type, fill it,
 and transfer it to the process component definition here.  The
 allocation is moved, so the original allocated object is returned empty.
 <<Process libraries: process def: TBP>>=
   procedure :: import_component => process_def_import_component
 <<Process libraries: procedures>>=
   subroutine process_def_import_component (def, &
        i, n_out, prt_in, prt_out, method, variant, &
        nlo_type, can_be_integrated)
     class(process_def_t), intent(inout) :: def
     integer, intent(in) :: i
     integer, intent(in), optional :: n_out
     type(prt_spec_t), dimension(:), intent(in), optional :: prt_in
     type(prt_spec_t), dimension(:), intent(in), optional :: prt_out
     type(string_t), intent(in), optional :: method
     integer, intent(in), optional :: nlo_type
     logical, intent(in), optional :: can_be_integrated
     type(string_t) :: nlo_type_string
     class(prc_core_def_t), &
          intent(inout), allocatable, optional :: variant
     integer :: p
     associate (comp => def%initial(i))
       if (present (n_out)) then
          comp%n_in  = def%n_in
          comp%n_out = n_out
          comp%n_tot = def%n_in + n_out
       end if
       if (present (prt_in)) then
          allocate (comp%prt_in (size (prt_in)))
          comp%prt_in = prt_in
       end if
       if (present (prt_out)) then
          allocate (comp%prt_out (size (prt_out)))
          comp%prt_out = prt_out
       end if
       if (present (method))  comp%method = method
       if (present (variant)) then
          call move_alloc (variant, comp%core_def)
       end if
       if (present (nlo_type)) then
         comp%nlo_type = nlo_type
       end if
       if (present (can_be_integrated)) then
          comp%active = can_be_integrated
       else
          comp%active = .true.
       end if
       if (allocated (comp%prt_in) .and. allocated (comp%prt_out)) then
          associate (d => comp%description)
            d = ""
            do p = 1, size (prt_in)
               if (p > 1)  d = d // ", "
               d = d // comp%prt_in(p)%to_string ()
            end do
            d = d // " => "
            do p = 1, size (prt_out)
               if (p > 1)  d = d // ", "
               d = d // comp%prt_out(p)%to_string ()
            end do
            if (comp%method /= "") then
               if ((def%nlo_process .and. .not. comp%active) .or. &
                    comp%nlo_type == NLO_SUBTRACTION) then
                  d = d // " [inactive]"
               else
                  d = d // " [" // comp%method // "]"
               end if
            end if
            nlo_type_string = component_status (comp%nlo_type)
            if (nlo_type_string /= "born") then
              d = d // ", [" // nlo_type_string // "]"
            end if
          end associate
       end if
     end associate
   end subroutine process_def_import_component
 
 @ %def process_def_import_component
 @
 <<Process libraries: process def: TBP>>=
   procedure :: get_n_components => process_def_get_n_components
 <<Process libraries: procedures>>=
   function process_def_get_n_components (def) result (n)
     class(process_def_t), intent(in) :: def
     integer :: n
     n = size (def%initial)
   end function process_def_get_n_components
 
 @ %def process_def_get_n_components
 @
 <<Process libraries: process def: TBP>>=
   procedure :: set_fixed_emitter => process_def_set_fixed_emitter
 <<Process libraries: procedures>>=
   subroutine process_def_set_fixed_emitter (def, i, emitter)
     class(process_def_t), intent(inout) :: def
     integer, intent(in) :: i, emitter
     def%initial(i)%fixed_emitter = emitter
   end subroutine process_def_set_fixed_emitter
 
 @ %def process_def_set_fixed_emitter
 @
 <<Process libraries: process def: TBP>>=
   procedure :: set_coupling_powers => process_def_set_coupling_powers
 <<Process libraries: procedures>>=
   subroutine process_def_set_coupling_powers (def, alpha_power, alphas_power)
     class(process_def_t), intent(inout) :: def
     integer, intent(in) :: alpha_power, alphas_power
     def%initial(1)%alpha_power = alpha_power
     def%initial(1)%alphas_power = alphas_power
   end subroutine process_def_set_coupling_powers
 
 @ %def process_def_set_coupling_powers
 @
 <<Process libraries: process def: TBP>>=
   procedure :: set_associated_components => &
        process_def_set_associated_components
 <<Process libraries: procedures>>=
   subroutine process_def_set_associated_components (def, i, &
        i_list, remnant, real_finite, mismatch)
     class(process_def_t), intent(inout) :: def
     logical, intent(in) :: remnant, real_finite, mismatch
     integer, intent(in) :: i
     integer, dimension(:), intent(in) :: i_list
     integer :: add_index
     add_index = 0
     associate (comp => def%initial(i)%associated_components)
        comp(ASSOCIATED_BORN) = i_list(1)
        comp(ASSOCIATED_REAL) = i_list(2)
        comp(ASSOCIATED_VIRT) = i_list(3)
        comp(ASSOCIATED_SUB) = i_list(4)
        if (remnant) then
           comp(ASSOCIATED_PDF) = i_list(5)
           add_index = add_index + 1
        end if
        if (real_finite) then
           comp(ASSOCIATED_REAL_FIN) = i_list(5+add_index)
           add_index = add_index + 1
        end if
        if (mismatch) then
           !!! incomplete
        end if
     end associate
   end subroutine process_def_set_associated_components
 
 @ %def process_def_set_associated_components
 @
 Compute the MD5 sum for this process definition.  We compute the MD5
 sums for all components individually, than concatenate a string of
 those and compute the MD5 sum of this string.  We also include the
 model name.  All other data part of the component definitions.
 <<Process libraries: process def: TBP>>=
   procedure :: compute_md5sum => process_def_compute_md5sum
 <<Process libraries: procedures>>=
   subroutine process_def_compute_md5sum (def, model)
     class(process_def_t), intent(inout) :: def
     class(model_data_t), intent(in), optional, target :: model
     integer :: i
     type(string_t) :: buffer
     buffer = def%model_name
     do i = 1, def%n_initial
        call def%initial(i)%compute_md5sum (model)
        buffer = buffer // def%initial(i)%md5sum
     end do
     do i = 1, def%n_extra
        call def%extra(i)%compute_md5sum (model)
        buffer = buffer // def%initial(i)%md5sum
     end do
     def%md5sum = md5sum (char (buffer))
   end subroutine process_def_compute_md5sum
 
 @ %def process_def_compute_md5sum
 @ Return the MD5 sum of the process or of a process component.
 <<Process libraries: process def: TBP>>=
   procedure :: get_md5sum => process_def_get_md5sum
 <<Process libraries: procedures>>=
   function process_def_get_md5sum (def, i_component) result (md5sum)
     class(process_def_t), intent(in) :: def
     integer, intent(in), optional :: i_component
     character(32) :: md5sum
     if (present (i_component)) then
        md5sum = def%initial(i_component)%md5sum
     else
        md5sum = def%md5sum
     end if
   end function process_def_get_md5sum
 
 @ %def process_def_get_md5sum
 @ Return a pointer to the definition of a particular component (for
 test purposes).
 <<Process libraries: process def: TBP>>=
   procedure :: get_core_def_ptr => process_def_get_core_def_ptr
 <<Process libraries: procedures>>=
   function process_def_get_core_def_ptr (def, i_component) result (ptr)
     class(process_def_t), intent(in), target :: def
     integer, intent(in) :: i_component
     class(prc_core_def_t), pointer :: ptr
     ptr => def%initial(i_component)%get_core_def_ptr ()
   end function process_def_get_core_def_ptr
 
 @ %def process_def_get_core_def_ptr
 @
 This query tells whether a specific process component relies on
 external code.  This includes all traditional WHIZARD matrix elements
 which rely on \oMega\ for code generation.  Other process components
 (trivial decays, subtraction terms) do not require external code.
 
 NOTE: Implemented only for initial component.
 
 The query is passed to the process component.
 <<Process libraries: process def: TBP>>=
   procedure :: needs_code => process_def_needs_code
 <<Process libraries: procedures>>=
   function process_def_needs_code (def, i_component) result (flag)
     class(process_def_t), intent(in) :: def
     integer, intent(in) :: i_component
     logical :: flag
     flag = def%initial(i_component)%needs_code ()
   end function process_def_needs_code
 
 @ %def process_def_needs_code
 @ Return the first entry for the incoming particle(s), PDG code, of
 this process.
 <<Process libraries: process def: TBP>>=
   procedure :: get_pdg_in_1 => process_def_get_pdg_in_1
 <<Process libraries: procedures>>=
   subroutine process_def_get_pdg_in_1 (def, pdg)
     class(process_def_t), intent(in), target :: def
     integer, dimension(:), intent(out) :: pdg
     call def%initial(1)%get_pdg_in (def%model, pdg)
   end subroutine process_def_get_pdg_in_1
 
 @ %def process_def_get_pdg_in_1
 @
 <<Process libraries: process def: TBP>>=
   procedure :: is_nlo => process_def_is_nlo
 <<Process libraries: procedures>>=
   elemental function process_def_is_nlo (def) result (flag)
     logical :: flag
     class(process_def_t), intent(in) :: def
     flag = def%nlo_process
   end function process_def_is_nlo
 
 @ %def process_def_is_nlo
 @
 <<Process libraries: process def: TBP>>=
   procedure :: get_nlo_type => process_def_get_nlo_type
 <<Process libraries: procedures>>=
   elemental function process_def_get_nlo_type (def, i_component) result (nlo_type)
     integer :: nlo_type
     class(process_def_t), intent(in) :: def
     integer, intent(in) :: i_component
     nlo_type = def%initial(i_component)%nlo_type
   end function process_def_get_nlo_type
 
 @ %def process_def_get_nlo_type
 @ Number of incoming particles, common to all components.
 <<Process libraries: process def: TBP>>=
   procedure :: get_n_in => process_def_get_n_in
 <<Process libraries: procedures>>=
   function process_def_get_n_in (def) result (n_in)
     class(process_def_t), intent(in) :: def
     integer :: n_in
     n_in = def%n_in
   end function process_def_get_n_in
 
 @ %def process_def_get_n_in
 @ Pointer to a particular component definition record.
 <<Process libraries: process def: TBP>>=
   procedure :: get_component_def_ptr => process_def_get_component_def_ptr
 <<Process libraries: procedures>>=
   function process_def_get_component_def_ptr (def, i) result (component)
     type(process_component_def_t), pointer :: component
     class(process_def_t), intent(in), target :: def
     integer, intent(in) :: i
     if (i <= def%n_initial) then
        component => def%initial(i)
     else
        component => null ()
     end if
   end function process_def_get_component_def_ptr
 
 @ %def process_def_get_component_def_ptr
 @
 \subsubsection{Process definition list}
 A list of process definitions is the starting point for creating a
 process library.  The list is built when reading the user input.  When
 reading an existing process library, the list is used for
 cross-checking and updating the configuration.
 
 We need a type for the list entry.  The simplest way is to extend the
 process definition type, so all methods apply to the process
 definition directly.
 <<Process libraries: public>>=
   public :: process_def_entry_t
 <<Process libraries: types>>=
   type, extends (process_def_t) :: process_def_entry_t
      private
      type(process_def_entry_t), pointer :: next => null ()
   end type process_def_entry_t
 
 @ %def process_def_entry_t
 @ This is the type for the list itself.
 <<Process libraries: public>>=
   public :: process_def_list_t
 <<Process libraries: types>>=
   type :: process_def_list_t
      private
      type(process_def_entry_t), pointer :: first => null ()
      type(process_def_entry_t), pointer :: last => null ()
    contains
    <<Process libraries: process def list: TBP>>
   end type process_def_list_t
 
 @ %def process_def_list_t
 @ The deallocates the list iteratively.  We assume that the list
 entries do not need finalization themselves.
 <<Process libraries: process def list: TBP>>=
   procedure :: final => process_def_list_final
 <<Process libraries: procedures>>=
   subroutine process_def_list_final (list)
     class(process_def_list_t), intent(inout) :: list
     type(process_def_entry_t), pointer :: current
     nullify (list%last)
     do while (associated (list%first))
        current => list%first
        list%first => current%next
        deallocate (current)
     end do
   end subroutine process_def_list_final
 
 @ %def process_def_list_final
 @ Write the complete list.
 <<Process libraries: process def list: TBP>>=
   procedure :: write => process_def_list_write
 <<Process libraries: procedures>>=
   subroutine process_def_list_write (object, unit, libpath)
     class(process_def_list_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: libpath
     type(process_def_entry_t), pointer :: entry
     integer :: i, u
     u = given_output_unit (unit)
     if (associated (object%first)) then
        i = 1
        entry => object%first
        do while (associated (entry))
           write (u, "(1x,A,I0,A)")  "Process #", i, ":"
           call entry%write (u)
           i = i + 1
           entry => entry%next
           if (associated (entry))  write (u, *)
        end do
     else
        write (u, "(1x,A)")  "Process definition list: [empty]"
     end if
   end subroutine process_def_list_write
 
 @ %def process_def_list_write
 @ Short account.
 <<Process libraries: process def list: TBP>>=
   procedure :: show => process_def_list_show
 <<Process libraries: procedures>>=
   subroutine process_def_list_show (object, unit)
     class(process_def_list_t), intent(in) :: object
     integer, intent(in), optional :: unit
     type(process_def_entry_t), pointer :: entry
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%first)) then
        write (u, "(2x,A)")  "Processes:"
        entry => object%first
        do while (associated (entry))
           call entry%show (u)
           entry => entry%next
        end do
     else
        write (u, "(2x,A)")  "Processes: [empty]"
     end if
   end subroutine process_def_list_show
 
 @ %def process_def_list_show
 @ Read the complete list.  We need an array of templates for the
 component subobjects of abstract [[prc_core_t]] type, to
 allocate them with the correct specific type.
 
 NOTE: Error handling is missing.  Reading will just be aborted on
 error, or an I/O error occurs.
 <<Process libraries: process def list: TBP>>=
   procedure :: read => process_def_list_read
 <<Process libraries: procedures>>=
   subroutine process_def_list_read (object, unit, core_def_templates)
     class(process_def_list_t), intent(out) :: object
     integer, intent(in) :: unit
     type(prc_template_t), dimension(:), intent(in) :: core_def_templates
     type(process_def_entry_t), pointer :: entry
     character(80) :: buffer, ref
     integer :: i
     read (unit, "(A)")  buffer
     write (ref, "(1x,A)")  "Process definition list: [empty]"
     if (buffer == ref)  return         ! OK: empty library
     backspace (unit)
     READ_ENTRIES: do i = 1, huge (0)
        if (i > 1) read (unit, *, end=1)
        read (unit, "(A)")  buffer
 
        write (ref, "(1x,A,I0,A)")  "Process #", i, ":"
        if (buffer /= ref)  return      ! Wrong process header: done.
        allocate (entry)
        call entry%read (unit, core_def_templates)
        call object%append (entry)
     end do READ_ENTRIES
 1   continue                           ! EOF: done
   end subroutine process_def_list_read
 
 @ %def process_def_list_read
 @ Append an entry to the list.  The entry should be allocated as a
 pointer, and the pointer allocation is transferred.  The original
 pointer is returned null.
 <<Process libraries: process def list: TBP>>=
   procedure :: append => process_def_list_append
 <<Process libraries: procedures>>=
   subroutine process_def_list_append (list, entry)
     class(process_def_list_t), intent(inout) :: list
     type(process_def_entry_t), intent(inout), pointer :: entry
     if (list%contains (entry%id)) then
        call msg_fatal ("Recording process: '" // char (entry%id) &
             // "' has already been defined")
     end if
     if (associated (list%first)) then
        list%last%next => entry
     else
        list%first => entry
     end if
     list%last => entry
     entry => null ()
   end subroutine process_def_list_append
 
 @ %def process_def_list_append
 @
 \subsubsection{Probe the process definition list}
 Return the number of processes supported by the library.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_n_processes => process_def_list_get_n_processes
 <<Process libraries: procedures>>=
   function process_def_list_get_n_processes (list) result (n)
     integer :: n
     class(process_def_list_t), intent(in) :: list
     type(process_def_entry_t), pointer :: current
     n = 0
     current => list%first
     do while (associated (current))
        n = n + 1
        current => current%next
     end do
   end function process_def_list_get_n_processes
 
 @ %def process_def_list_get_n_processes
 @ Allocate an array with the process IDs supported by the library.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_process_id_list => process_def_list_get_process_id_list
 <<Process libraries: procedures>>=
   subroutine process_def_list_get_process_id_list (list, id)
     class(process_def_list_t), intent(in) :: list
     type(string_t), dimension(:), allocatable, intent(out) :: id
     type(process_def_entry_t), pointer :: current
     integer :: i
     allocate (id (list%get_n_processes ()))
     i = 0
     current => list%first
     do while (associated (current))
        i = i + 1
        id(i) = current%id
        current => current%next
     end do
   end subroutine process_def_list_get_process_id_list
 
 @ %def process_def_list_get_process_id_list
 @ Return just the processes which require resonant subprocesses.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_process_id_req_resonant => &
        process_def_list_get_process_id_req_resonant
 <<Process libraries: procedures>>=
   subroutine process_def_list_get_process_id_req_resonant (list, id)
     class(process_def_list_t), intent(in) :: list
     type(string_t), dimension(:), allocatable, intent(out) :: id
     type(process_def_entry_t), pointer :: current
     integer :: i
     allocate (id (list%get_n_processes ()))
     i = 0
     current => list%first
     do while (associated (current))
        if (current%requires_resonances) then
           i = i + 1
           id(i) = current%id
        end if
        current => current%next
     end do
     id = id(1:i)
   end subroutine process_def_list_get_process_id_req_resonant
 
 @ %def process_def_list_get_process_id_list
 @ Return a pointer to a particular process entry.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_process_def_ptr => process_def_list_get_process_def_ptr
 <<Process libraries: procedures>>=
   function process_def_list_get_process_def_ptr (list, id) result (entry)
     type(process_def_entry_t), pointer :: entry
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     type(process_def_entry_t), pointer :: current
     current => list%first
     do while (associated (current))
        if (id == current%id)  exit
        current => current%next
     end do
     entry => current
   end function process_def_list_get_process_def_ptr
 
 @ %def process_def_list_get_process_def_ptr  
 @ Return true if a given process is in the library.
 <<Process libraries: process def list: TBP>>=
   procedure :: contains => process_def_list_contains
 <<Process libraries: procedures>>=
   function process_def_list_contains (list, id) result (flag)
     logical :: flag
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     type(process_def_entry_t), pointer :: current
     current => list%get_process_def_ptr (id)
     flag = associated (current)
   end function process_def_list_contains
 
 @ %def process_def_list_contains
 @ Return the index of the entry that corresponds to a given process.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_entry_index => process_def_list_get_entry_index
 <<Process libraries: procedures>>=
   function process_def_list_get_entry_index (list, id) result (n)
     integer :: n
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     type(process_def_entry_t), pointer :: current
     n = 0
     current => list%first
     do while (associated (current))
        n = n + 1
        if (id == current%id) then
           return
        end if
        current => current%next
     end do
     n = 0
   end function process_def_list_get_entry_index
 
 @ %def process_def_list_get_entry_index
 @ Return the numerical ID for a process.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_num_id => process_def_list_get_num_id
 <<Process libraries: procedures>>=
   function process_def_list_get_num_id (list, id) result (num_id)
     integer :: num_id
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     type(process_def_entry_t), pointer :: current
     current => list%get_process_def_ptr (id)
     if (associated (current)) then
        num_id = current%num_id
     else
        num_id = 0
     end if
   end function process_def_list_get_num_id
 
 @ %def process_def_list_get_num_id
 @ Return the model name for a given process in the library.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_model_name => process_def_list_get_model_name
 <<Process libraries: procedures>>=
   function process_def_list_get_model_name (list, id) result (model_name)
     type(string_t) :: model_name
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     type(process_def_entry_t), pointer :: current
     current => list%get_process_def_ptr (id)
     if (associated (current)) then
        model_name = current%model_name
     else
        model_name = ""
     end if
   end function process_def_list_get_model_name
 
 @ %def process_def_list_get_model_name
 @ Return the number of incoming particles of a given process in the library.
 This tells us whether the process is a decay or a scattering.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_n_in => process_def_list_get_n_in
 <<Process libraries: procedures>>=
   function process_def_list_get_n_in (list, id) result (n)
     integer :: n
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     type(process_def_entry_t), pointer :: current
     current => list%get_process_def_ptr (id)
     if (associated (current)) then
        n = current%n_in
     else
        n = 0
     end if
   end function process_def_list_get_n_in
 
 @ %def process_def_list_get_n_in
 @ Return the incoming particle pdg codesnumber of incoming particles
 of a given process in the library.  If there is a PDG array, return
 only the first code for each beam.  This serves as a quick way
 for (re)constructing beam properties.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_pdg_in_1 => process_def_list_get_pdg_in_1
 <<Process libraries: procedures>>=
   subroutine process_def_list_get_pdg_in_1 (list, id, pdg)
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     integer, dimension(:), intent(out) :: pdg
     type(process_def_entry_t), pointer :: current
     current => list%get_process_def_ptr (id)
     if (associated (current)) then
        call current%get_pdg_in_1 (pdg)
     else
        pdg = 0
     end if
   end subroutine process_def_list_get_pdg_in_1
 
 @ %def process_def_list_get_pdg_in_1
 @ Return the list of component IDs of a given process in the library.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_component_list => process_def_list_get_component_list
 <<Process libraries: procedures>>=
   subroutine process_def_list_get_component_list (list, id, cid)
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     type(string_t), dimension(:), allocatable, intent(out) :: cid
     type(process_def_entry_t), pointer :: current
     integer :: i, n
     current => list%get_process_def_ptr (id)
     if (associated (current)) then
        allocate (cid (current%n_initial + current%n_extra))
        do i = 1, current%n_initial
           cid(i) = current%initial(i)%basename
        end do
        n = current%n_initial
        do i = 1, current%n_extra
           cid(n + i) = current%extra(i)%basename
        end do
     end if
   end subroutine process_def_list_get_component_list
 
 @ %def process_def_list_get_component_list
 @ Return the list of component description strings for a given process
 in the library.
 <<Process libraries: process def list: TBP>>=
   procedure :: get_component_description_list => &
        process_def_list_get_component_description_list
 <<Process libraries: procedures>>=
   subroutine process_def_list_get_component_description_list &
        (list, id, description)
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     type(string_t), dimension(:), allocatable, intent(out) :: description
     type(process_def_entry_t), pointer :: current
     integer :: i, n
     current => list%get_process_def_ptr (id)
     if (associated (current)) then
        allocate (description (current%n_initial + current%n_extra))
        do i = 1, current%n_initial
           description(i) = current%initial(i)%description
        end do
        n = current%n_initial
        do i = 1, current%n_extra
           description(n + i) = current%extra(i)%description
        end do
     end if
   end subroutine process_def_list_get_component_description_list
 
 @ %def process_def_list_get_component_description_list
 @ Return whether the entry requires construction of a resonanct
 subprocess set.
 <<Process libraries: process def list: TBP>>=
   procedure :: req_resonant => process_def_list_req_resonant
 <<Process libraries: procedures>>=
   function process_def_list_req_resonant (list, id) result (flag)
     class(process_def_list_t), intent(in) :: list
     type(string_t), intent(in) :: id
     logical :: flag
     type(process_def_entry_t), pointer :: current
     current => list%get_process_def_ptr (id)
     if (associated (current)) then
        flag = current%requires_resonances
     else
        flag = .false.
     end if
   end function process_def_list_req_resonant
 
 @ %def process_def_list_req_resonant
 @
 \subsection{Process library}
 The process library object is the interface between the process
 definition data, as provided by the user, generated or linked process
 code on file, and the process run data that reference the process
 code.
 
 \subsubsection{Process library entry}
 For each process component that is part of the library, there is a
 separate library entry ([[process_library_entry_t]].  The library
 entry connects a process definition with the specific code (if any) in
 the compiled driver library.
 
 The [[status]] indicates how far the process has been
 processed by the system (definition, code generation, compilation,
 linking).  A process with status [[STAT_LOADED]] is accessible for
 computing matrix elements.
 
 The [[def]] pointer identifies the corresponding process definition.
 The process component within that definition is identified by the
 [[i_component]] index.
 
 The [[i_external]] index refers to the compiled library driver.  If it is zero,
 there is no associated matrix-element code.
 
 The [[driver]] component holds the pointers to the matrix-element
 specific functions, in particular the matrix element function itself.
 <<Process libraries: types>>=
   type :: process_library_entry_t
      private
      integer :: status = STAT_UNKNOWN
      type(process_def_t), pointer :: def => null ()
      integer :: i_component = 0
      integer :: i_external = 0
      class(prc_core_driver_t), allocatable :: driver
    contains
    <<Process libraries: process library entry: TBP>>
   end type process_library_entry_t
 
 @ %def process_library_entry_t
 @ Here are the available status codes.  An entry starts with
 [[UNKNOWN]] status.  Once the association with a valid process
 definition is established, the status becomes [[CONFIGURED]].
 If matrix element source code is to be generated by the system or
 provided from elsewhere, [[CODE_GENERATED]] indicates that this is
 done.  The [[COMPILED]] status is next, it also applies to
 processes which are accessed as precompiled binaries.  Finally, the
 library is linked and process pointers are set; this is marked as
 [[LOADED]].
 
 For a process library, the initial status is [[OPEN]], since process
 definitions may be added.  After configuration, the process content is fixed
 and the status becomes [[CONFIGURED]].  The further states are as above,
 always referring to the lowest status among the process entries.
 <<Process libraries: parameters>>=
   integer, parameter, public :: STAT_UNKNOWN = 0
   integer, parameter, public :: STAT_OPEN = 1
   integer, parameter, public :: STAT_CONFIGURED = 2
   integer, parameter, public :: STAT_SOURCE = 3
   integer, parameter, public :: STAT_COMPILED = 4
   integer, parameter, public :: STAT_LINKED = 5
   integer, parameter, public :: STAT_ACTIVE = 6
 
   integer, parameter, public :: ASSOCIATED_BORN = 1
   integer, parameter, public :: ASSOCIATED_REAL = 2
   integer, parameter, public :: ASSOCIATED_VIRT = 3
   integer, parameter, public :: ASSOCIATED_SUB = 4
   integer, parameter, public :: ASSOCIATED_PDF = 5
   integer, parameter, public :: ASSOCIATED_REAL_SING = 6
   integer, parameter, public :: ASSOCIATED_REAL_FIN = 7
   integer, parameter, public :: N_ASSOCIATED_COMPONENTS = 7
 
 @ %def STAT_UNKNOWN STAT_OPEN STAT_CONFIGURED
 @ %def STAT_SOURCE STAT_COMPILED STAT_LINKED STAT_ACTIVE
 @ These are the associated code letters, for output:
 <<Process libraries: parameters>>=
   character, dimension(0:6), parameter :: STATUS_LETTER = &
        ["?", "o", "f", "s", "c", "l", "a"]
 
 @ %def STATUS_LETTER
 @ This produces a condensed account of the library entry.  The status
 is indicated by a letter in brackets, then the ID and component index
 of the associated process definition, finally the library index, if available.
 <<Process libraries: process library entry: TBP>>=
   procedure :: to_string => process_library_entry_to_string
 <<Process libraries: procedures>>=
   function process_library_entry_to_string (object) result (string)
     type(string_t) :: string
     class(process_library_entry_t), intent(in) :: object
     character(32) :: buffer
     string = "[" // STATUS_LETTER(object%status) // "]"
     select case (object%status)
     case (STAT_UNKNOWN)
     case default
        if (associated (object%def)) then
           write (buffer, "(I0)")  object%i_component
           string = string // " " // object%def%id // "." // trim (buffer)
        end if
        if (object%i_external /= 0) then
           write (buffer, "(I0)")  object%i_external
           string = string // " = ext:" // trim (buffer)
        else
           string = string // " = int"
        end if
        if (allocated (object%driver)) then
           string = string // " (" // object%driver%type_name () // ")"
        end if
     end select
   end function process_library_entry_to_string
 
 @ %def process_library_entry_to_string
 @ Initialize with data.  Used for the unit tests.
 <<Process libraries: process library entry: TBP>>=
   procedure :: init => process_library_entry_init
 <<Process libraries: procedures>>=
   subroutine process_library_entry_init (object, &
        status, def, i_component, i_external, driver_template)
     class(process_library_entry_t), intent(out) :: object
     integer, intent(in) :: status
     type(process_def_t), target, intent(in) :: def
     integer, intent(in) :: i_component
     integer, intent(in) :: i_external
     class(prc_core_driver_t), intent(inout), allocatable, optional &
          :: driver_template
     object%status = status
     object%def => def
     object%i_component = i_component
     object%i_external = i_external
     if (present (driver_template)) then
        call move_alloc (driver_template, object%driver)
     end if
   end subroutine process_library_entry_init
 
 @ %def process_library_entry_init
 @ Assign pointers for all process-specific features.  We have to
 combine the method from the [[core_def]] specification, the
 assigned pointers within the library driver, the index within that
 driver, and the process driver which should receive the links.
 <<Process libraries: process library entry: TBP>>=
   procedure :: connect => process_library_entry_connect
 <<Process libraries: procedures>>=
   subroutine process_library_entry_connect (entry, lib_driver, i)
     class(process_library_entry_t), intent(inout) :: entry
     class(prclib_driver_t), intent(in) :: lib_driver
     integer, intent(in) :: i
     call entry%def%initial(entry%i_component)%connect &
          (lib_driver, i, entry%driver)
   end subroutine process_library_entry_connect
 
 @ %def process_library_entry_connect
 @
 \subsubsection{The process library object}
 The [[process_library_t]] type is an extension of the
 [[process_def_list_t]] type.  Thus, it automatically contains the
 process definition list.
 
 The [[basename]] identifies the library generically.
 
 The [[external]] flag is true if any process within the library needs external
 code, so the library must correspond to an actual code library (statically or
 dynamically linked).
 
 The [[entry]] array contains all process components that can be handled by this
 library. Each entry refers to the process (component) definition and to the
 associated external matrix element code, if there is any.
 
 The [[driver]] object is needed only if [[external]] is true.  This object
 handles all interactions with external matrix-element code.
 
 The [[md5sum]] summarizes the complete [[process_def_list_t]] base
 object.  It can be used to check if the library configuration has changed.
 <<Process libraries: public>>=
   public :: process_library_t
 <<Process libraries: types>>=
   type, extends (process_def_list_t) :: process_library_t
      private
      type(string_t) :: basename
      integer :: n_entries = 0
      logical :: external = .false.
      integer :: status = STAT_UNKNOWN
      logical :: static = .false.
      logical :: driver_exists = .false.
      logical :: makefile_exists = .false.
      integer :: update_counter = 0
      type(process_library_entry_t), dimension(:), allocatable :: entry
      class(prclib_driver_t), allocatable :: driver
      character(32) :: md5sum = ""
    contains
    <<Process libraries: process library: TBP>>
   end type process_library_t
 
 @ %def process_library_t
 @ For the output, we write first the metadata and the DL access
 record, then the library entries in short form, and finally the
 process definition list which is the base object.
 
 Don't write the MD5 sum since this is used to generate it.
 <<Process libraries: process library: TBP>>=
   procedure :: write => process_library_write
 <<Process libraries: procedures>>=
   subroutine process_library_write (object, unit, libpath)
     class(process_library_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: libpath
     integer :: i, u
     u = given_output_unit (unit)
     write (u, "(1x,A,A)")  "Process library: ", char (object%basename)
     write (u, "(3x,A,L1)")   "external        = ", object%external
     write (u, "(3x,A,L1)")   "makefile exists = ", object%makefile_exists
     write (u, "(3x,A,L1)")   "driver exists   = ", object%driver_exists
     write (u, "(3x,A,A1)")   "code status     = ", &
          STATUS_LETTER (object%status)
     write (u, *)
     if (allocated (object%entry)) then
        write (u, "(1x,A)", advance="no")  "Process library entries:"
        write (u, "(1x,I0)")  object%n_entries
        do i = 1, size (object%entry)
           write (u, "(1x,A,I0,A,A)")  "Entry #", i, ": ", &
                char (object%entry(i)%to_string ())
        end do
        write (u, *)
     end if
     if (object%external) then
        call object%driver%write (u, libpath)
        write (u, *)
     end if
     call object%process_def_list_t%write (u)
   end subroutine process_library_write
 
 @ %def process_library_write
 @ Condensed version for screen output.
 <<Process libraries: process library: TBP>>=
   procedure :: show => process_library_show
 <<Process libraries: procedures>>=
   subroutine process_library_show (object, unit)
     class(process_library_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(A,A)")  "Process library: ", char (object%basename)
     write (u, "(2x,A,L1)")   "external        = ", object%external
     if (object%static) then
        write (u, "(2x,A,L1)")   "static          = ", .true.
     else
        write (u, "(2x,A,L1)")   "makefile exists = ", object%makefile_exists
        write (u, "(2x,A,L1)")   "driver exists   = ", object%driver_exists
     end if
     write (u, "(2x,A,A1)", advance="no")   "code status     = "
     select case (object%status)
     case (STAT_UNKNOWN);    write (u, "(A)")  "[unknown]"
     case (STAT_OPEN);       write (u, "(A)")  "open"
     case (STAT_CONFIGURED); write (u, "(A)")  "configured"
     case (STAT_SOURCE);     write (u, "(A)")  "source code exists"
     case (STAT_COMPILED);   write (u, "(A)")  "compiled"
     case (STAT_LINKED);     write (u, "(A)")  "linked"
     case (STAT_ACTIVE);     write (u, "(A)")  "active"
     end select
     call object%process_def_list_t%show (u)
   end subroutine process_library_show
 
 @ %def process_library_show
 @
 The initializer defines just the basename.  We may now add process definitions
 to the library.
 <<Process libraries: process library: TBP>>=
   procedure :: init => process_library_init
 <<Process libraries: procedures>>=
   subroutine process_library_init (lib, basename)
     class(process_library_t), intent(out) :: lib
     type(string_t), intent(in) :: basename
     lib%basename = basename
     lib%status = STAT_OPEN
     call msg_message ("Process library '" // char (basename) &
          // "': initialized")
   end subroutine process_library_init
 
 @ %def process_library_init
 @
 This alternative initializer declares the library as static.  We
 should now add process definitions to the library, but all external
 process code exists already.  We need the driver object, and we should
 check the defined processes against the stored ones.
 <<Process libraries: process library: TBP>>=
   procedure :: init_static => process_library_init_static
 <<Process libraries: procedures>>=
   subroutine process_library_init_static (lib, basename)
     class(process_library_t), intent(out) :: lib
     type(string_t), intent(in) :: basename
     lib%basename = basename
     lib%status = STAT_OPEN
     lib%static = .true.
     call msg_message ("Static process library '" // char (basename) &
          // "': initialized")
   end subroutine process_library_init_static
 
 @ %def process_library_init_static
 @ The [[configure]] procedure scans the allocated entries in the process
 definition list.  The configuration proceeds in three passes.
 
 In the first pass, we scan the process definition list and count the
 number of process components and the number of components which need
 external code.  This is used to allocate the [[entry]] array.
 
 In the second pass, we initialize the [[entry]] elements which connect
 process definitions, process driver objects, and external code.
 
 In the third pass, we initialize the library driver object, allocating
 an entry for each external matrix element.
 
 NOTE: Currently we handle only [[initial]] process components; [[extra]]
 components are ignored.
 <<Process libraries: process library: TBP>>=
   procedure :: configure => process_library_configure
 <<Process libraries: procedures>>=
   subroutine process_library_configure (lib, os_data)
     class(process_library_t), intent(inout) :: lib
     type(os_data_t), intent(in) :: os_data
     type(process_def_entry_t), pointer :: def_entry
     integer :: n_entries, n_external, i_entry, i_external
     type(string_t) :: model_name
     integer :: i_component
 
     n_entries = 0
     n_external = 0
     if (allocated (lib%entry))  deallocate (lib%entry)
 
     def_entry => lib%first
     do while (associated (def_entry))
        do i_component = 1, def_entry%n_initial
           n_entries = n_entries + 1
           if (def_entry%initial(i_component)%needs_code ()) then
              n_external = n_external + 1
              lib%external = .true.
           end if
        end do
        def_entry => def_entry%next
     end do
 
     call lib%allocate_entries (n_entries)
 
     i_entry = 0
     i_external = 0
     def_entry => lib%first
     do while (associated (def_entry))
        do i_component = 1, def_entry%n_initial
           i_entry = i_entry + 1
           associate (lib_entry => lib%entry(i_entry))
             lib_entry%status = STAT_CONFIGURED
             lib_entry%def => def_entry%process_def_t
             lib_entry%i_component = i_component
             if (def_entry%initial(i_component)%needs_code ()) then
                i_external = i_external + 1
                lib_entry%i_external = i_external
             end if
             call def_entry%initial(i_component)%allocate_driver &
                  (lib_entry%driver)
           end associate
        end do
        def_entry => def_entry%next
     end do
 
     call dispatch_prclib_driver (lib%driver, &
          lib%basename, lib%get_modellibs_ldflags (os_data))
     call lib%driver%init (n_external)
     do i_entry = 1, n_entries
        associate (lib_entry => lib%entry(i_entry))
          i_component = lib_entry%i_component
          model_name = lib_entry%def%model_name
          associate (def => lib_entry%def%initial(i_component))
            if (def%needs_code ()) then
               call lib%driver%set_record (lib_entry%i_external, &
                    def%basename, &
                    model_name, &
                    def%get_features (), def%get_writer_ptr ())
            end if
          end associate
        end associate
     end do
 
     if (lib%static) then
        if (lib%n_entries /= 0)  lib%entry%status = STAT_LINKED
        lib%status = STAT_LINKED
     else if (lib%external) then
        where (lib%entry%i_external == 0)  lib%entry%status = STAT_LINKED
        lib%status = STAT_CONFIGURED
        lib%makefile_exists = .false.
        lib%driver_exists = .false.
     else
        if (lib%n_entries /= 0)  lib%entry%status = STAT_LINKED
        lib%status = STAT_LINKED
     end if
   end subroutine process_library_configure
 
 @ %def process_library_configure
 @ Basic setup: allocate the [[entry]] array.
 <<Process libraries: process library: TBP>>=
   procedure :: allocate_entries => process_library_allocate_entries
 <<Process libraries: procedures>>=
   subroutine process_library_allocate_entries (lib, n_entries)
     class(process_library_t), intent(inout) :: lib
     integer, intent(in) :: n_entries
     lib%n_entries = n_entries
     allocate (lib%entry (n_entries))
   end subroutine process_library_allocate_entries
 
 @ %def process_library_allocate_entries
 @ Initialize an entry with data (used by unit tests).
 <<Process libraries: process library: TBP>>=
   procedure :: init_entry => process_library_init_entry
 <<Process libraries: procedures>>=
   subroutine process_library_init_entry (lib, i, &
        status, def, i_component, i_external, driver_template)
     class(process_library_t), intent(inout) :: lib
     integer, intent(in) :: i
     integer, intent(in) :: status
     type(process_def_t), target, intent(in) :: def
     integer, intent(in) :: i_component
     integer, intent(in) :: i_external
     class(prc_core_driver_t), intent(inout), allocatable, optional &
          :: driver_template
     call lib%entry(i)%init (status, def, i_component, i_external, &
          driver_template)
   end subroutine process_library_init_entry
 
 @ %def process_library_init_entry
 @ Compute the MD5 sum.  We concatenate the individual MD5 sums of all
 processes (which, in turn, are derived from the MD5 sums of their
 components) and compute the MD5 sum of that.
 
 This should be executed \emph{after} configuration, where the driver was
 initialized, since otherwise the MD5 sum stored in the driver would be
 overwritten.
 <<Process libraries: process library: TBP>>=
   procedure :: compute_md5sum => process_library_compute_md5sum
 <<Process libraries: procedures>>=
   subroutine process_library_compute_md5sum (lib, model)
     class(process_library_t), intent(inout) :: lib
     class(model_data_t), intent(in), optional, target :: model
     type(process_def_entry_t), pointer :: def_entry
     type(string_t) :: buffer
     buffer = lib%basename
     def_entry => lib%first
     do while (associated (def_entry))
        call def_entry%compute_md5sum (model)
        buffer = buffer // def_entry%md5sum
        def_entry => def_entry%next
     end do
     lib%md5sum = md5sum (char (buffer))
     call lib%driver%set_md5sum (lib%md5sum)
   end subroutine process_library_compute_md5sum
 
 @ %def process_library_compute_md5sum
 @ Write an appropriate makefile, if there are external processes.  Unless
 [[force]] is in effect, first check if there is already a makefile with the
 correct MD5 sum.  If yes, do nothing.
 
 The [[workspace]] optional argument puts any library code in a subdirectory.
 <<Process libraries: process library: TBP>>=
   procedure :: write_makefile => process_library_write_makefile
 <<Process libraries: procedures>>=
   subroutine process_library_write_makefile &
        (lib, os_data, force, verbose, testflag, workspace)
     class(process_library_t), intent(inout) :: lib
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: force, verbose
     logical, intent(in), optional :: testflag
     type(string_t), intent(in), optional :: workspace
     character(32) :: md5sum_file
     logical :: generate
     integer :: unit
     if (lib%external .and. .not. lib%static) then
        generate = .true.
        if (.not. force) then
           md5sum_file = lib%driver%get_md5sum_makefile (workspace)
           if (lib%md5sum == md5sum_file) then
              call msg_message ("Process library '" // char (lib%basename) &
                   // "': keeping makefile")
              generate = .false.
           end if
        end if
        if (generate) then
           call msg_message ("Process library '" // char (lib%basename) &
                // "': writing makefile")
           unit = free_unit ()
           open (unit, &
                file = char (workspace_prefix (workspace) &
                &            // lib%driver%basename // ".makefile"), &
                status="replace", action="write")
           call lib%driver%generate_makefile (unit, os_data, verbose, testflag)
           close (unit)
        end if
        lib%makefile_exists = .true.
     end if
   end subroutine process_library_write_makefile
 
 @ %def process_library_write_makefile
 @ 
 @ Write the driver source code for the library to file, if there are
 external processes.
 <<Process libraries: process library: TBP>>=
   procedure :: write_driver => process_library_write_driver
 <<Process libraries: procedures>>=
   subroutine process_library_write_driver (lib, force, workspace)
     class(process_library_t), intent(inout) :: lib
     logical, intent(in) :: force
     type(string_t), intent(in), optional :: workspace
     character(32) :: md5sum_file
     logical :: generate
     integer :: unit
     if (lib%external .and. .not. lib%static) then
        generate = .true.
        if (.not. force) then
           md5sum_file = lib%driver%get_md5sum_driver (workspace)
           if (lib%md5sum == md5sum_file) then
              call msg_message ("Process library '" // char (lib%basename) &
                   // "': keeping driver")
              generate = .false.
           end if
        end if
        if (generate) then
           call msg_message ("Process library '" // char (lib%basename) &
                // "': writing driver")
           unit = free_unit ()
           open (unit, & 
                file = char (workspace_prefix (workspace) &
                &            // lib%driver%basename // ".f90"), &
                status="replace", action="write")
           call lib%driver%generate_driver_code (unit)
           close (unit)
        end if
        lib%driver_exists = .true.
     end if
   end subroutine process_library_write_driver
 
 @ %def process_library_write_driver
 @ Update the compilation status of an external library.
 
 Strictly speaking, this is not necessary for a one-time run, since the
 individual library methods will update the status themselves.
 However, it allows us to identify compilation steps that we can skip
 because the file exists or is already loaded, for the whole library or
 for particular entries.
 
 Independently, the building process is controlled by a makefile.
 Thus, previous files are reused if they are not modified by the
 current compilation.
 \begin{enumerate}
 \item
   If it is not already loaded, attempt to load the library.  If successful,
   check the overall MD5 sum.  If it matches, just keep it loaded and mark as
   ACTIVE.  If not, check the MD5 sum for all linked process components.
   Where it matches, mark the entry as COMPILED.  Then, unload the library and
   mark as CONFIGURED.
 
   Thus, we can identify compiled files for all matrix elements which are
   accessible via the previous compiled library, even if it is no longer up to
   date.
 \item
   If the library is now in CONFIGURED state, look for valid source files.
   Each entry that is just in CONFIGURED state will advance to SOURCE if the
   MD5 sum matches.  Finally, advance the whole library to SOURCE if all
   entries are at least in this condition.
 \end{enumerate}
 <<Process libraries: process library: TBP>>=
   procedure :: update_status => process_library_update_status
 <<Process libraries: procedures>>=
   subroutine process_library_update_status (lib, os_data, workspace)
     class(process_library_t), intent(inout) :: lib
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in), optional :: workspace
     character(32) :: md5sum_file
     integer :: i, i_external, i_component
     if (lib%external) then
        select case (lib%status)
        case (STAT_CONFIGURED:STAT_LINKED)
           call lib%driver%load (os_data, noerror=.true., workspace=workspace)
        end select
        if (lib%driver%loaded) then
           md5sum_file = lib%driver%get_md5sum (0)
           if (lib%md5sum == md5sum_file) then
              call lib%load_entries ()
              lib%entry%status = STAT_ACTIVE
              lib%status = STAT_ACTIVE
              call msg_message ("Process library '" // char (lib%basename) &
                   // "': active")
           else
              do i = 1, lib%n_entries
                 associate (entry => lib%entry(i))
                   i_external = entry%i_external
                   i_component = entry%i_component
                   if (i_external /= 0) then
                      md5sum_file = lib%driver%get_md5sum (i_external)
                      if (entry%def%get_md5sum (i_component) == md5sum_file) then
                         entry%status = STAT_COMPILED
                      else
                         entry%status = STAT_CONFIGURED
                      end if
                   end if
                 end associate
              end do
              call lib%driver%unload ()
              lib%status = STAT_CONFIGURED
           end if
        end if
        select case (lib%status)
        case (STAT_CONFIGURED)
           do i = 1, lib%n_entries
              associate (entry => lib%entry(i))
                i_external = entry%i_external
                i_component = entry%i_component
                if (i_external /= 0) then
                   select case (entry%status)
                   case (STAT_CONFIGURED)
                      md5sum_file = lib%driver%get_md5sum_source &
                           (i_external, workspace)
                      if (entry%def%get_md5sum (i_component) == md5sum_file) then
                         entry%status = STAT_SOURCE
                      end if
                   end select
                end if
              end associate
           end do
           if (all (lib%entry%status >= STAT_SOURCE)) then
              md5sum_file = lib%driver%get_md5sum_driver (workspace)
              if (lib%md5sum == md5sum_file) then
                 lib%status = STAT_SOURCE
              end if
           end if
        end select
     end if
   end subroutine process_library_update_status
 
 @ %def process_library_update_status
 @
 This procedure triggers code generation for all processes where this
 is possible.
 
 We generate code only for external processes of status
 [[STAT_CONFIGURED]], which then advance to [[STAT_SOURCE]].  If, for a
 particular process, the status is already advanced, we do not remove previous
 files, so [[make]] will consider them as up to date if they exist.  Otherwise,
 we remove those files to force a fresh [[make]].
 
 Finally, if any source code has been generated, we need a driver file.
 <<Process libraries: process library: TBP>>=
   procedure :: make_source => process_library_make_source
 <<Process libraries: procedures>>=
   subroutine process_library_make_source &
        (lib, os_data, keep_old_source, workspace)
     class(process_library_t), intent(inout) :: lib
     type(os_data_t), intent(in) :: os_data
     logical, intent(in), optional :: keep_old_source
     type(string_t), intent(in), optional :: workspace
     logical :: keep_old
     integer :: i, i_external
     keep_old = .false.
     if (present (keep_old_source))  keep_old = keep_old_source
     if (lib%external .and. .not. lib%static) then
        select case (lib%status)
        case (STAT_CONFIGURED)
           if (keep_old) then
              call msg_message ("Process library '" // char (lib%basename) &
                   // "': keeping source code")
           else
              call msg_message ("Process library '" // char (lib%basename) &
                   // "': creating source code")
              do i = 1, size (lib%entry)
                 associate (entry => lib%entry(i))
                   i_external = entry%i_external
                   if (i_external /= 0 &
                        .and. lib%entry(i)%status == STAT_CONFIGURED) then
                      call lib%driver%clean_proc &
                           (i_external, os_data, workspace)
                   end if
                 end associate
                 if (signal_is_pending ())  return
              end do
              call lib%driver%make_source (os_data, workspace)
           end if
           lib%status = STAT_SOURCE
           where (lib%entry%i_external /= 0 &
                .and. lib%entry%status == STAT_CONFIGURED)
              lib%entry%status = STAT_SOURCE
           end where
           lib%status = STAT_SOURCE
        end select
     end if
   end subroutine process_library_make_source
 
 @ %def process_library_make_source
 @ Compile the generated code and update the status codes.  Try to make
 the sources first, just in case. This includes compiling possible \LaTeX
 Feynman diagram files.
 <<Process libraries: process library: TBP>>=
   procedure :: make_compile => process_library_make_compile
 <<Process libraries: procedures>>=
   subroutine process_library_make_compile &
        (lib, os_data, keep_old_source, workspace)
     class(process_library_t), intent(inout) :: lib
     type(os_data_t), intent(in) :: os_data
     logical, intent(in), optional :: keep_old_source
     type(string_t), intent(in), optional :: workspace
     if (lib%external .and. .not. lib%static) then
        select case (lib%status)
        case (STAT_CONFIGURED)
           call lib%make_source (os_data, keep_old_source, workspace)
        end select
        if (signal_is_pending ())  return
        select case (lib%status)
        case (STAT_SOURCE)
           call msg_message ("Process library '" // char (lib%basename) &
                // "': compiling sources")
           call lib%driver%make_compile (os_data, workspace)
           where (lib%entry%i_external /= 0 &
                .and. lib%entry%status == STAT_SOURCE)
              lib%entry%status = STAT_COMPILED
           end where
           lib%status = STAT_COMPILED
        end select
     end if
   end subroutine process_library_make_compile
 
 @ %def process_library_make_compile
 @ Link the process library.  Try to compile first, just in case.
 <<Process libraries: process library: TBP>>=
   procedure :: make_link => process_library_make_link
 <<Process libraries: procedures>>=
   subroutine process_library_make_link &
        (lib, os_data, keep_old_source, workspace)
     class(process_library_t), intent(inout) :: lib
     type(os_data_t), intent(in) :: os_data
     logical, intent(in), optional :: keep_old_source
     type(string_t), intent(in), optional :: workspace
     if (lib%external .and. .not. lib%static) then
        select case (lib%status)
        case (STAT_CONFIGURED:STAT_SOURCE)
           call lib%make_compile (os_data, keep_old_source, workspace)
        end select
        if (signal_is_pending ())  return
        select case (lib%status)
        case (STAT_COMPILED)
           call msg_message ("Process library '" // char (lib%basename) &
                // "': linking")
           call lib%driver%make_link (os_data, workspace)
           lib%entry%status = STAT_LINKED
           lib%status = STAT_LINKED
        end select
     end if
   end subroutine process_library_make_link
 
 @ %def process_library_make_link
 @ Load the process library, i.e., assign pointers to the library
 functions.
 <<Process libraries: process library: TBP>>=
   procedure :: load => process_library_load
 <<Process libraries: procedures>>=
   subroutine process_library_load (lib, os_data, keep_old_source, workspace)
     class(process_library_t), intent(inout) :: lib
     type(os_data_t), intent(in) :: os_data
     logical, intent(in), optional :: keep_old_source
     type(string_t), intent(in), optional :: workspace
     select case (lib%status)
     case (STAT_CONFIGURED:STAT_COMPILED)
        call lib%make_link (os_data, keep_old_source, workspace)
     end select
     if (signal_is_pending ())  return
     select case (lib%status)
     case (STAT_LINKED)
        if (lib%external) then
           call msg_message ("Process library '" // char (lib%basename) &
                // "': loading")
           call lib%driver%load (os_data, workspace=workspace)
           call lib%load_entries ()
        end if
        lib%entry%status = STAT_ACTIVE
        lib%status = STAT_ACTIVE
     end select
   end subroutine process_library_load
 
 @ %def process_library_load
 @ This is the actual loading part for the process methods.
 <<Process libraries: process library: TBP>>=
   procedure :: load_entries => process_library_load_entries
 <<Process libraries: procedures>>=
   subroutine process_library_load_entries (lib)
     class(process_library_t), intent(inout) :: lib
     integer :: i
     do i = 1, size (lib%entry)
        associate (entry => lib%entry(i))
          if (entry%i_external /= 0) then
             call entry%connect (lib%driver, entry%i_external)
          end if
        end associate
     end do
   end subroutine process_library_load_entries
 
 @ %def process_library_load_entries
 @ Unload the library, if possible.  This reverts the status to ``linked''.
 <<Process libraries: process library: TBP>>=
   procedure :: unload => process_library_unload
 <<Process libraries: procedures>>=
   subroutine process_library_unload (lib)
     class(process_library_t), intent(inout) :: lib
     select case (lib%status)
     case (STAT_ACTIVE)
        if (lib%external) then
           call msg_message ("Process library '" // char (lib%basename) &
                // "': unloading")
           call lib%driver%unload ()
        end if
        lib%entry%status = STAT_LINKED
        lib%status = STAT_LINKED
     end select
   end subroutine process_library_unload
 
 @ %def process_library_unload
 @ Unload, clean all generated files and revert the library status.  If
 [[distclean]] is set, also remove the makefile and the driver source.
 <<Process libraries: process library: TBP>>=
   procedure :: clean => process_library_clean
 <<Process libraries: procedures>>=
   subroutine process_library_clean (lib, os_data, distclean, workspace)
     class(process_library_t), intent(inout) :: lib
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: distclean
     type(string_t), intent(in), optional :: workspace
     call lib%unload ()
     if (lib%external .and. .not. lib%static) then
        call msg_message ("Process library '" // char (lib%basename) &
             // "': removing old files")
        if (distclean) then
           call lib%driver%distclean (os_data, workspace)
        else
           call lib%driver%clean (os_data, workspace)
        end if
     end if
     where (lib%entry%i_external /= 0)
        lib%entry%status = STAT_CONFIGURED
     elsewhere
        lib%entry%status = STAT_LINKED
     end where
     if (lib%external) then
        lib%status = STAT_CONFIGURED
     else
        lib%status = STAT_LINKED
     end if
   end subroutine process_library_clean
 
 @ %def process_library_clean
 @ Unload and revert the library status to INITIAL.  This allows for
 appending new processes.  No files are deleted.
 <<Process libraries: process library: TBP>>=
   procedure :: open => process_library_open
 <<Process libraries: procedures>>=
   subroutine process_library_open (lib)
     class(process_library_t), intent(inout) :: lib
     select case (lib%status)
     case (STAT_OPEN)
     case default
        call lib%unload ()
        if (.not. lib%static) then
           lib%entry%status = STAT_OPEN
           lib%status = STAT_OPEN
           if (lib%external)  lib%update_counter = lib%update_counter + 1
           call msg_message ("Process library '" // char (lib%basename) &
                // "': open")
        else
           call msg_error ("Static process library '" // char (lib%basename) &
                // "': processes can't be appended")
        end if
     end select
   end subroutine process_library_open
 
 @ %def process_library_open
 @
 \subsection{Use the library}
 Return the base name of the library
 <<Process libraries: process library: TBP>>=
   procedure :: get_name => process_library_get_name
 <<Process libraries: procedures>>=
   function process_library_get_name (lib) result (name)
     class(process_library_t), intent(in) :: lib
     type(string_t) :: name
     name = lib%basename
   end function process_library_get_name
 
 @ %def process_library_get_name
 @
 Once activated, we view the process library object as an interface for
 accessing the matrix elements.
 <<Process libraries: process library: TBP>>=
   procedure :: is_active => process_library_is_active
 <<Process libraries: procedures>>=
   function process_library_is_active (lib) result (flag)
     logical :: flag
     class(process_library_t), intent(in) :: lib
     flag = lib%status == STAT_ACTIVE
   end function process_library_is_active
 
 @ %def process_library_is_active
 @ Return the current status code of the library.  If an index is
 provided, return the status of that entry.
 <<Process libraries: process library: TBP>>=
   procedure :: get_status => process_library_get_status
 <<Process libraries: procedures>>=
   function process_library_get_status (lib, i) result (status)
     class(process_library_t), intent(in) :: lib
     integer, intent(in), optional :: i
     integer :: status
     if (present (i)) then
        status = lib%entry(i)%status
     else
        status = lib%status
     end if
   end function process_library_get_status
 
 @ %def process_library_get_status
 @ Return the update counter.  Since this is incremented each time the
 library is re-opened, we can use this to check if existing pointers to
 matrix element code are still valid.
 <<Process libraries: process library: TBP>>=
   procedure :: get_update_counter => process_library_get_update_counter
 <<Process libraries: procedures>>=
   function process_library_get_update_counter (lib) result (counter)
     class(process_library_t), intent(in) :: lib
     integer :: counter
     counter = lib%update_counter
   end function process_library_get_update_counter
 
 @ %def process_library_get_update_counter
 @ Manually set the current status code of the library.  If the
 optional flag is set, set also the entry status codes.  This is used
 for unit tests.
 <<Process libraries: process library: TBP>>=
   procedure :: set_status => process_library_set_status
 <<Process libraries: procedures>>=
   subroutine process_library_set_status (lib, status, entries)
     class(process_library_t), intent(inout) :: lib
     integer, intent(in) :: status
     logical, intent(in), optional :: entries
     lib%status = status
     if (present (entries)) then
        if (entries)  lib%entry%status = status
     end if
   end subroutine process_library_set_status
 
 @ %def process_library_set_status
 @ Return the load status of the associated driver.
 <<Process libraries: process library: TBP>>=
   procedure :: is_loaded => process_library_is_loaded
 <<Process libraries: procedures>>=
   function process_library_is_loaded (lib) result (flag)
     class(process_library_t), intent(in) :: lib
     logical :: flag
     flag = lib%driver%loaded
   end function process_library_is_loaded
 
 @ %def process_library_is_loaded
 @ Retrieve constants using the process library driver.  We assume that
 the process code has been loaded, if external.
 <<Process libraries: process library entry: TBP>>=
   procedure :: fill_constants => process_library_entry_fill_constants
 <<Process libraries: procedures>>=
   subroutine process_library_entry_fill_constants (entry, driver, data)
     class(process_library_entry_t), intent(in) :: entry
     class(prclib_driver_t), intent(in) :: driver
     type(process_constants_t), intent(out) :: data
     integer :: i
     if (entry%i_external /= 0) then
        i = entry%i_external
        data%id         = driver%get_process_id (i)
        data%model_name = driver%get_model_name (i)
        data%md5sum     = driver%get_md5sum (i)
        data%openmp_supported = driver%get_openmp_status (i)
        data%n_in  = driver%get_n_in  (i)
        data%n_out = driver%get_n_out (i)
        data%n_flv = driver%get_n_flv (i)
        data%n_hel = driver%get_n_hel (i)
        data%n_col = driver%get_n_col (i)
        data%n_cin = driver%get_n_cin (i)
        data%n_cf  = driver%get_n_cf  (i)
        call driver%set_flv_state (i, data%flv_state)
        call driver%set_hel_state (i, data%hel_state)
        call driver%set_col_state (i, data%col_state, data%ghost_flag)
        call driver%set_color_factors (i, data%color_factors, data%cf_index)
     else
        select type (proc_driver => entry%driver)
        class is (process_driver_internal_t)
           call proc_driver%fill_constants (data)
        end select
     end if
   end subroutine process_library_entry_fill_constants
 
 @ %def process_library_entry_fill_constants
 @ Retrieve the constants for a process
 <<Process libraries: process library: TBP>>=
   procedure :: fill_constants => process_library_fill_constants
 <<Process libraries: procedures>>=
   subroutine process_library_fill_constants (lib, id, i_component, data)
     class(process_library_t), intent(in) :: lib
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     type(process_constants_t), intent(out) :: data
     integer :: i
     do i = 1, size (lib%entry)
        associate (entry => lib%entry(i))
           if (entry%def%id == id .and. entry%i_component == i_component) then
              call entry%fill_constants (lib%driver, data)
              return
           end if
        end associate
     end do
   end subroutine process_library_fill_constants
 
 @ %def process_library_fill_constants
 @ Retrieve the constants and a connected driver for a process,
 identified by a process ID and a subprocess index.  We
 scan the process entries until we have found a match.
 <<Process libraries: process library: TBP>>=
   procedure :: connect_process => process_library_connect_process
 <<Process libraries: procedures>>=
   subroutine process_library_connect_process &
        (lib, id, i_component, data, proc_driver)
     class(process_library_t), intent(in) :: lib
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     type(process_constants_t), intent(out) :: data
     class(prc_core_driver_t), allocatable, intent(out) :: proc_driver
     integer :: i
     do i = 1, size (lib%entry)
        associate (entry => lib%entry(i))
          if (entry%def%id == id .and. entry%i_component == i_component) then
             call entry%fill_constants (lib%driver, data)
             allocate (proc_driver, source = entry%driver)
             return
          end if
        end associate
     end do
     call msg_fatal ("Process library '" // char (lib%basename) &
                // "': process '" // char (id) // "' not found")
   end subroutine process_library_connect_process
 
 @ %def process_library_connect_process
 @
 Shortcut for use in unit tests: fetch the MD5sum from a specific
 library entry and inject it into the writer of a specific record.
 <<Process libraries: process library: TBP>>=
   procedure :: test_transfer_md5sum => process_library_test_transfer_md5sum
 <<Process libraries: procedures>>=
   subroutine process_library_test_transfer_md5sum (lib, r, e, c)
     class(process_library_t), intent(inout) :: lib
     integer, intent(in) :: r, e, c
     associate (writer => lib%driver%record(r)%writer)
        writer%md5sum = lib%entry(e)%def%get_md5sum (c)
     end associate
   end subroutine process_library_test_transfer_md5sum
 
 @ %def process_library_test_transfer_md5sum
 @
 <<Process libraries: process library: TBP>>=
   procedure :: get_nlo_type => process_library_get_nlo_type
 <<Process libraries: procedures>>=
   function process_library_get_nlo_type (lib, id, i_component) result (nlo_type)
     integer :: nlo_type
     class(process_library_t), intent(in) :: lib
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     integer :: i
     do i = 1, size (lib%entry)
        if (lib%entry(i)%def%id == id .and. lib%entry(i)%i_component == i_component) then
           nlo_type = lib%entry(i)%def%get_nlo_type (i_component)
           exit
        end if
     end do
   end function process_library_get_nlo_type
 
 @ %def process_library_get_nlo_type
 @
 \subsection{Collect model-specific libraries}
 This returns appropriate linker flags for the model parameter libraries that
 are used by the generated matrix element.  At the end, the main libwhizard is
 appended (again), because functions from that may be reqired.
 
 Extra models in the local user space need to be treated individually.
 <<Process libraries: process library: TBP>>=
   procedure :: get_modellibs_ldflags => process_library_get_modellibs_ldflags
 <<Process libraries: procedures>>=
   function process_library_get_modellibs_ldflags (prc_lib, os_data) result (flags)
     class(process_library_t), intent(in) :: prc_lib
     type(os_data_t), intent(in) :: os_data
     type(string_t) :: flags
     type(string_t), dimension(:), allocatable :: models
     type(string_t) :: modelname, modellib, modellib_full
     logical :: exist
     integer :: i, j, mi
     flags = " -lomega"
     if ((.not. os_data%use_testfiles) .and. &
 	       os_dir_exist (os_data%whizard_models_libpath_local)) &
 		 flags = flags // " -L" // os_data%whizard_models_libpath_local
     flags = flags // " -L" // os_data%whizard_models_libpath
     allocate (models(prc_lib%n_entries + 1))
     models = ""
     mi = 1
     if (allocated (prc_lib%entry)) then
        SCAN: do i = 1, prc_lib%n_entries
           if (associated (prc_lib%entry(i)%def)) then
              if (prc_lib%entry(i)%def%model_name /= "") then
                 modelname = prc_lib%entry(i)%def%model_name
              else
                 cycle SCAN
              end if
           else
              cycle SCAN
           end if
           do j = 1, mi
              if (models(mi) == modelname) cycle SCAN
           end do
           models(mi) = modelname
           mi = mi + 1
           if (os_data%use_libtool) then
              modellib = "libparameters_" // modelname // ".la"
           else
              modellib = "libparameters_" // modelname // ".a"
           end if
           exist = .false.
           if (.not. os_data%use_testfiles) then
              modellib_full = os_data%whizard_models_libpath_local &
                   // "/" // modellib
              inquire (file=char (modellib_full), exist=exist)
           end if
           if (.not. exist) then
              modellib_full = os_data%whizard_models_libpath &
                   // "/" // modellib
              inquire (file=char (modellib_full), exist=exist)
           end if
           if (exist) flags = flags // " -lparameters_" // modelname
        end do SCAN
     end if
     deallocate (models)
     flags = flags // " -lwhizard"
   end function process_library_get_modellibs_ldflags
 
 @ %def process_library_get_modellibs_ldflags
 @
 <<Process libraries: process library: TBP>>=
   procedure :: get_static_modelname => process_library_get_static_modelname
 <<Process libraries: procedures>>=
   function process_library_get_static_modelname (prc_lib, os_data) result (name)
     class(process_library_t), intent(in) :: prc_lib
     type(os_data_t), intent(in) :: os_data
     type(string_t) :: name
     type(string_t), dimension(:), allocatable :: models
     type(string_t) :: modelname, modellib, modellib_full
     logical :: exist
     integer :: i, j, mi
     name = ""
     allocate (models(prc_lib%n_entries + 1))
     models = ""
     mi = 1
     if (allocated (prc_lib%entry)) then
        SCAN: do i = 1, prc_lib%n_entries
           if (associated (prc_lib%entry(i)%def)) then
              if (prc_lib%entry(i)%def%model_name /= "") then
                 modelname = prc_lib%entry(i)%def%model_name
              else
                 cycle SCAN
              end if
           else
              cycle SCAN
           end if
           do j = 1, mi
              if (models(mi) == modelname) cycle SCAN
           end do
           models(mi) = modelname
           mi = mi + 1
           modellib = "libparameters_" // modelname // ".a"
           exist = .false.
           if (.not. os_data%use_testfiles) then
              modellib_full = os_data%whizard_models_libpath_local &
                   // "/" // modellib
              inquire (file=char (modellib_full), exist=exist)
           end if
           if (.not. exist) then
              modellib_full = os_data%whizard_models_libpath &
                   // "/" // modellib
              inquire (file=char (modellib_full), exist=exist)
           end if
           if (exist) name = name // " " // modellib_full
        end do SCAN
     end if
     deallocate (models)
   end function process_library_get_static_modelname
 
 @ %def process_library_get_static_modelname
 @
 \subsection{Unit Test}
 Test module, followed by the corresponding implementation module.
 <<[[process_libraries_ut.f90]]>>=
 <<File header>>
 
 module process_libraries_ut
   use unit_tests
   use process_libraries_uti
 
 <<Standard module head>>
 
 <<Process libraries: public test>>
 
 contains
 
 <<Process libraries: test driver>>
 
 end module process_libraries_ut
 @ %def process_libraries_ut
 @
 <<[[process_libraries_uti.f90]]>>=
 <<File header>>
 
 module process_libraries_uti
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use strings>>
   use io_units
   use os_interface
   use particle_specifiers, only: new_prt_spec
   use process_constants
   use prclib_interfaces
   use prc_core_def
 
   use process_libraries
 
   use prclib_interfaces_ut, only: test_writer_4_t
 
 <<Standard module head>>
 
 <<Process libraries: test declarations>>
 
 <<Process libraries: test types>>
 
 contains
 
 <<Process libraries: tests>>
 
 <<Process libraries: test auxiliary>>
 
 end module process_libraries_uti
 @ %def process_libraries_ut
 @ API: driver for the unit tests below.
 <<Process libraries: public test>>=
   public :: process_libraries_test
 <<Process libraries: test driver>>=
   subroutine process_libraries_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Process libraries: execute tests>>
   end subroutine process_libraries_test
 
 @ %def process_libraries_test
 @
 \subsubsection{Empty process list}
 Test 1: Write an empty process list.
 <<Process libraries: execute tests>>=
   call test (process_libraries_1, "process_libraries_1", &
        "empty process list", &
        u, results)
 <<Process libraries: test declarations>>=
   public :: process_libraries_1
 <<Process libraries: tests>>=
   subroutine process_libraries_1 (u)
     integer, intent(in) :: u
     type(process_def_list_t) :: process_def_list
 
     write (u, "(A)")  "* Test output: process_libraries_1"
     write (u, "(A)")  "*   Purpose: Display an empty process definition list"
     write (u, "(A)")
 
     call process_def_list%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_libraries_1"
   end subroutine process_libraries_1
 
 @ %def process_libraries_1
 @
 \subsubsection{Process definition list}
 Test 2: Process definition list with processes and components.
 Construct the list, write to file, read it in again, and display.
 Finalize and delete the list after use.
 
 We define a trivial 'test' type for the process variant.  The test
 type contains just one (meaningless) data item, which is an integer.
 <<Process libraries: test types>>=
   type, extends (prc_core_def_t) :: prcdef_2_t
      integer :: data = 0
      logical :: file = .false.
    contains
    <<Process libraries: prcdef 2: TBP>>
   end type prcdef_2_t
 
 @ %def prcdef_2_t
 @ The process variant is named 'test'.
 <<Process libraries: prcdef 2: TBP>>=
   procedure, nopass :: type_string => prcdef_2_type_string
 <<Process libraries: test auxiliary>>=
   function prcdef_2_type_string () result (string)
     type(string_t) :: string
     string = "test"
   end function prcdef_2_type_string
 
 @ %def prcdef_2_type_string
 @ Write the contents (the integer value).
 <<Process libraries: prcdef 2: TBP>>=
   procedure :: write => prcdef_2_write
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_2_write (object, unit)
     class(prcdef_2_t), intent(in) :: object
     integer, intent(in) :: unit
     write (unit, "(3x,A,I0)")  "Test data         = ", object%data
   end subroutine prcdef_2_write
 
 @ %def prcdef_2_write
 @ Recover the integer value.
 <<Process libraries: prcdef 2: TBP>>=
   procedure :: read => prcdef_2_read
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_2_read (object, unit)
     class(prcdef_2_t), intent(out) :: object
     integer, intent(in) :: unit
     character(80) :: buffer
     read (unit, "(A)")  buffer
     call strip_equation_lhs (buffer)
     read (buffer, *)  object%data
   end subroutine prcdef_2_read
 
 @ %def prcdef_2_read
 @ No external procedures.
 <<Process libraries: prcdef 2: TBP>>=
   procedure, nopass :: get_features => prcdef_2_get_features
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_2_get_features (features)
     type(string_t), dimension(:), allocatable, intent(out) :: features
     allocate (features (0))
   end subroutine prcdef_2_get_features
 
 @ %def prcdef_2_get_features
 @ No code generated.
 <<Process libraries: prcdef 2: TBP>>=
   procedure :: generate_code => prcdef_2_generate_code
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_2_generate_code (object, &
        basename, model_name, prt_in, prt_out)
     class(prcdef_2_t), intent(in) :: object
     type(string_t), intent(in) :: basename
     type(string_t), intent(in) :: model_name
     type(string_t), dimension(:), intent(in) :: prt_in
     type(string_t), dimension(:), intent(in) :: prt_out
   end subroutine prcdef_2_generate_code
 
 @ %def prcdef_2_generate_code
 @ Allocate the driver with the appropriate type.
 <<Process libraries: prcdef 2: TBP>>=
   procedure :: allocate_driver => prcdef_2_allocate_driver
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_2_allocate_driver (object, driver, basename)
     class(prcdef_2_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     allocate (prctest_2_t :: driver)
   end subroutine prcdef_2_allocate_driver
 
 @ %def prcdef_2_allocate_driver
 @ Nothing to connect.
 <<Process libraries: prcdef 2: TBP>>=
   procedure :: connect => prcdef_2_connect
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_2_connect (def, lib_driver, i, proc_driver)
     class(prcdef_2_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
   end subroutine prcdef_2_connect
 
 @ %def prcdef_2_connect
 @ The associated driver type.
 <<Process libraries: test types>>=
   type, extends (process_driver_internal_t) :: prctest_2_t
    contains
    <<Process libraries: prctest 2: TBP>>
   end type prctest_2_t
 
 @ %def prctest_2_t
 @ Return the type name.
 <<Process libraries: prctest 2: TBP>>=
   procedure, nopass :: type_name => prctest_2_type_name
 <<Process libraries: test auxiliary>>=
   function prctest_2_type_name () result (type)
     type(string_t) :: type
     type = "test"
   end function prctest_2_type_name
 
 @ %def prctest_2_type_name
 @ This should fill constant process data.  We do not check those here,
 however, therefore nothing done.
 <<Process libraries: prctest 2: TBP>>=
   procedure :: fill_constants => prctest_2_fill_constants
 <<Process libraries: test auxiliary>>=
   subroutine prctest_2_fill_constants (driver, data)
     class(prctest_2_t), intent(in) :: driver
     type(process_constants_t), intent(out) :: data
   end subroutine prctest_2_fill_constants
 
 @ %def prctest_2_fill_constants
 @
 Here is the actual test.
 
 For reading, we need a list of templates, i.e., an array containing
 allocated objects for all available process variants.  This is the
 purpose of [[process_core_templates]].  Here, we have only a single
 template for the 'test' variant.
 <<Process libraries: execute tests>>=
   call test (process_libraries_2, "process_libraries_2", &
        "process definition list", &
        u, results)
 <<Process libraries: test declarations>>=
   public :: process_libraries_2
 <<Process libraries: tests>>=
   subroutine process_libraries_2 (u)
     integer, intent(in) :: u
     type(prc_template_t), dimension(:), allocatable :: process_core_templates
     type(process_def_list_t) :: process_def_list
     type(process_def_entry_t), pointer :: entry => null ()
     class(prc_core_def_t), allocatable :: test_def
     integer :: scratch_unit
 
     write (u, "(A)")  "* Test output: process_libraries_2"
     write (u, "(A)")  "* Purpose: Construct a process definition list,"
     write (u, "(A)")  "*          write it to file and reread it"
     write (u, "(A)")  ""
     write (u, "(A)")  "* Construct a process definition list"
     write (u, "(A)")  "*   First process definition: empty"
     write (u, "(A)")  "*   Second process definition: two components"
     write (u, "(A)")  "*     First component: empty"
     write (u, "(A)")  "*     Second component: test data"
     write (u, "(A)")  "*   Third process definition:"
     write (u, "(A)")  "*     Embedded decays and polarization"
     write (u, "(A)")
 
     allocate (process_core_templates (1))
     allocate (prcdef_2_t :: process_core_templates(1)%core_def)
 
     allocate (entry)
     call entry%init (var_str ("first"), n_in = 0, n_components = 0)
     call entry%compute_md5sum ()
     call process_def_list%append (entry)
 
     allocate (entry)
     call entry%init (var_str ("second"), model_name = var_str ("Test"), &
          n_in = 1, n_components = 2)
     allocate (prcdef_2_t :: test_def)
     select type (test_def)
     type is (prcdef_2_t);  test_def%data = 42
     end select
     call entry%import_component (2, n_out = 2, &
          prt_in  = new_prt_spec ([var_str ("a")]), &
          prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), &
          method  = var_str ("test"), &
          variant = test_def)
     call entry%compute_md5sum ()
     call process_def_list%append (entry)
 
     allocate (entry)
     call entry%init (var_str ("third"), model_name = var_str ("Test"), &
          n_in = 2, n_components = 1)
     allocate (prcdef_2_t :: test_def)
     call entry%import_component (1, n_out = 3, &
          prt_in  = &
            new_prt_spec ([var_str ("a"), var_str ("b")]), &
          prt_out = &
            [new_prt_spec (var_str ("c")), &
             new_prt_spec (var_str ("d"), .true.), &
             new_prt_spec (var_str ("e"), [var_str ("e_decay")])], &
          method  = var_str ("test"), &
          variant = test_def)
     call entry%compute_md5sum ()
     call process_def_list%append (entry)
     call process_def_list%write (u)
 
     write (u, "(A)")  ""
     write (u, "(A)")  "* Write the process definition list to (scratch) file"
 
     scratch_unit = free_unit ()
     open (unit = scratch_unit, status="scratch", action = "readwrite")
     call process_def_list%write (scratch_unit)
     call process_def_list%final ()
 
     write (u, "(A)")  "* Reread it"
     write (u, "(A)")  ""
 
     rewind (scratch_unit)
     call process_def_list%read (scratch_unit, process_core_templates)
     close (scratch_unit)
 
     call process_def_list%write (u)
     call process_def_list%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_libraries_2"
   end subroutine process_libraries_2
 
 @ %def process_libraries_2
 @
 \subsubsection{Process library object}
 Test 3: Process library object with several process definitions and
 library entries.  Just construct the object, modify some initial
 content, and write the result.  The modifications are mostly applied
 directly, so we do not test anything but the contents and the output
 routine.
 <<Process libraries: execute tests>>=
   call test (process_libraries_3, "process_libraries_3", &
        "recover process definition list from file", &
        u, results)
 <<Process libraries: test declarations>>=
   public :: process_libraries_3
 <<Process libraries: tests>>=
   subroutine process_libraries_3 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     type(process_def_entry_t), pointer :: entry
     class(prc_core_driver_t), allocatable :: driver_template
 
     write (u, "(A)")  "* Test output: process_libraries_3"
     write (u, "(A)")  "* Purpose: Construct a process library object &
          &with entries"
     write (u, "(A)")  ""
     write (u, "(A)")  "* Construct and display a process library object"
     write (u, "(A)")  "*   with 5 entries"
     write (u, "(A)")  "*   associated with 3 matrix element codes"
     write (u, "(A)")  "*   corresponding to 3 process definitions"
     write (u, "(A)")  "*   with 2, 1, 1 components, respectively"
     write (u, "(A)")
 
     call lib%init (var_str ("testlib"))
 
     call lib%set_status (STAT_ACTIVE)
     call lib%allocate_entries (5)
 
     allocate (entry)
     call entry%init (var_str ("test_a"), n_in = 2, n_components = 2)
     allocate (prctest_2_t :: driver_template)
     call lib%init_entry (3, STAT_SOURCE, entry%process_def_t, 2, 2, &
          driver_template)
     call lib%init_entry (4, STAT_COMPILED, entry%process_def_t, 1, 0)
     call lib%append (entry)
 
     allocate (entry)
     call entry%init (var_str ("test_b"), n_in = 2, n_components = 1)
     call lib%init_entry (2, STAT_CONFIGURED, entry%process_def_t, 1, 1)
     call lib%append (entry)
 
     allocate (entry)
     call entry%init (var_str ("test_c"), n_in = 2, n_components = 1)
     allocate (prctest_2_t :: driver_template)
     call lib%init_entry (5, STAT_LINKED, entry%process_def_t, 1, 3, &
          driver_template)
     call lib%append (entry)
 
     call lib%write (u)
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_libraries_3"
   end subroutine process_libraries_3
 
 @ %def process_libraries_3
 @
 \subsubsection{Process library for test matrix element (no file)}
 Test 4: We proceed through the library generation and loading phases
 with a test matrix element type that needs no code written on file.
 <<Process libraries: execute tests>>=
   call test (process_libraries_4, "process_libraries_4", &
        "build and load internal process library", &
        u, results)
 <<Process libraries: test declarations>>=
   public :: process_libraries_4
 <<Process libraries: tests>>=
   subroutine process_libraries_4 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     type(process_def_entry_t), pointer :: entry
     class(prc_core_def_t), allocatable :: core_def
     type(os_data_t) :: os_data
 
     write (u, "(A)")  "* Test output: process_libraries_4"
     write (u, "(A)")  "* Purpose: build a process library with an &
          &internal (pseudo) matrix element"
     write (u, "(A)")  "*          No Makefile or code should be generated"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry &
          &(no external code)"
     write (u, "(A)")
     call os_data%init ()
     call lib%init (var_str ("proclibs4"))
 
     allocate (prcdef_2_t :: core_def)
 
     allocate (entry)
     call entry%init (var_str ("proclibs4_a"), n_in = 1, n_components = 1)
     call entry%import_component (1, n_out = 2, variant = core_def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure library"
     write (u, "(A)")
     call lib%configure (os_data)
 
     write (u, "(A)")  "* Compute MD5 sum"
     write (u, "(A)")
     call lib%compute_md5sum ()
 
     write (u, "(A)")  "* Write makefile (no-op)"
     write (u, "(A)")
     call lib%write_makefile (os_data, force = .true., verbose = .true.)
 
     write (u, "(A)")  "* Write driver source code (no-op)"
     write (u, "(A)")
     call lib%write_driver (force = .true.)
 
     write (u, "(A)")  "* Write process source code (no-op)"
     write (u, "(A)")
     call lib%make_source (os_data)
 
     write (u, "(A)")  "* Compile (no-op)"
     write (u, "(A)")
     call lib%make_compile (os_data)
 
     write (u, "(A)")  "* Link (no-op)"
     write (u, "(A)")
     call lib%make_link (os_data)
 
     write (u, "(A)")  "* Load (no-op)"
     write (u, "(A)")
     call lib%load (os_data)
 
     call lib%write (u)
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_libraries_4"
   end subroutine process_libraries_4
 
 @ %def process_libraries_4
 @
 \subsubsection{Build workflow for test matrix element}
 Test 5: We write source code for a dummy process.
 
 We define another trivial type for the process variant.  The test
 type contains just no variable data, but produces code on file.
 <<Process libraries: test types>>=
   type, extends (prc_core_def_t) :: prcdef_5_t
    contains
    <<Process libraries: prcdef 5: TBP>>
   end type prcdef_5_t
 
 @ %def prcdef_5_t
 @ The process variant is named [[test_file]].
 <<Process libraries: prcdef 5: TBP>>=
   procedure, nopass :: type_string => prcdef_5_type_string
 <<Process libraries: test auxiliary>>=
   function prcdef_5_type_string () result (string)
     type(string_t) :: string
     string = "test_file"
   end function prcdef_5_type_string
 
 @ %def prcdef_5_type_string
 @ We reuse the writer [[test_writer_4]] from the previous module.
 <<Process libraries: prcdef 5: TBP>>=
   procedure :: init => prcdef_5_init
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_5_init (object)
     class(prcdef_5_t), intent(out) :: object
     allocate (test_writer_4_t :: object%writer)
   end subroutine prcdef_5_init
 
 @ %def prcdef_5_init
 @ Nothing to write.
 <<Process libraries: prcdef 5: TBP>>=
   procedure :: write => prcdef_5_write
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_5_write (object, unit)
     class(prcdef_5_t), intent(in) :: object
     integer, intent(in) :: unit
   end subroutine prcdef_5_write
 
 @ %def prcdef_5_write
 @ Nothing to read.
 <<Process libraries: prcdef 5: TBP>>=
   procedure :: read => prcdef_5_read
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_5_read (object, unit)
     class(prcdef_5_t), intent(out) :: object
     integer, intent(in) :: unit
   end subroutine prcdef_5_read
 
 @ %def prcdef_5_read
 @ Allocate the driver with the appropriate type.
 <<Process libraries: prcdef 5: TBP>>=
   procedure :: allocate_driver => prcdef_5_allocate_driver
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_5_allocate_driver (object, driver, basename)
     class(prcdef_5_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     allocate (prctest_5_t :: driver)
   end subroutine prcdef_5_allocate_driver
 
 @ %def prcdef_5_allocate_driver
 @ This time we need code:
 <<Process libraries: prcdef 5: TBP>>=
   procedure, nopass :: needs_code => prcdef_5_needs_code
 <<Process libraries: test auxiliary>>=
   function prcdef_5_needs_code () result (flag)
     logical :: flag
     flag = .true.
   end function prcdef_5_needs_code
 
 @ %def prcdef_5_needs_code
 @ For the test case, we implement a single feature [[proc1]].
 <<Process libraries: prcdef 5: TBP>>=
   procedure, nopass :: get_features => prcdef_5_get_features
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_5_get_features (features)
     type(string_t), dimension(:), allocatable, intent(out) :: features
     allocate (features (1))
     features = [ var_str ("proc1") ]
   end subroutine prcdef_5_get_features
 
 @ %def prcdef_5_get_features
 @ Nothing to connect.
 <<Process libraries: prcdef 5: TBP>>=
   procedure :: connect => prcdef_5_connect
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_5_connect (def, lib_driver, i, proc_driver)
     class(prcdef_5_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
   end subroutine prcdef_5_connect
 
 @ %def prcdef_5_connect
 @ The driver type.
 <<Process libraries: test types>>=
   type, extends (prc_core_driver_t) :: prctest_5_t
    contains
    <<Process libraries: prctest 5: TBP>>
   end type prctest_5_t
 
 @ %def prctest_5_t
 @ Return the type name.
 <<Process libraries: prctest 5: TBP>>=
   procedure, nopass :: type_name => prctest_5_type_name
 <<Process libraries: test auxiliary>>=
   function prctest_5_type_name () result (type)
     type(string_t) :: type
     type = "test_file"
   end function prctest_5_type_name
 
 @ %def prctest_5_type_name
 @
 Here is the actual test:
 <<Process libraries: execute tests>>=
   call test (process_libraries_5, "process_libraries_5", &
        "build external process library", &
        u, results)
 <<Process libraries: test declarations>>=
   public :: process_libraries_5
 <<Process libraries: tests>>=
   subroutine process_libraries_5 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     type(process_def_entry_t), pointer :: entry
     class(prc_core_def_t), allocatable :: core_def
     type(os_data_t) :: os_data
 
     write (u, "(A)")  "* Test output: process_libraries_5"
     write (u, "(A)")  "* Purpose: build a process library with an &
          &external (pseudo) matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("proclibs5"))
     call os_data%init ()
 
     allocate (prcdef_5_t :: core_def)
     select type (core_def)
     type is (prcdef_5_t)
        call core_def%init ()
     end select
 
     allocate (entry)
     call entry%init (var_str ("proclibs5_a"), &
          model_name = var_str ("Test_Model"), &
          n_in = 1, n_components = 1)
     call entry%import_component (1, n_out = 2, &
          prt_in  = new_prt_spec ([var_str ("a")]), &
          prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), &
          method  = var_str ("test"), &
          variant = core_def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure library"
     write (u, "(A)")
     call lib%configure (os_data)
 
     write (u, "(A)")  "* Compute MD5 sum"
     write (u, "(A)")
     call lib%compute_md5sum ()
 
     write (u, "(A)")  "* Write makefile"
     write (u, "(A)")
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
 
     write (u, "(A)")  "* Write driver source code"
     write (u, "(A)")
     call lib%write_driver (force = .true.)
 
     write (u, "(A)")  "* Write process source code"
     write (u, "(A)")
     call lib%make_source (os_data)
 
     write (u, "(A)")  "* Compile"
     write (u, "(A)")
     call lib%make_compile (os_data)
 
     write (u, "(A)")  "* Link"
     write (u, "(A)")
     call lib%make_link (os_data)
 
     call lib%write (u, libpath = .false.)
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_libraries_5"
   end subroutine process_libraries_5
 
 @ %def process_libraries_5
 @
 \subsubsection{Build and load library with test matrix element}
 Test 6: We write source code for a dummy process.
 
 This process variant is identical to the previous case, but it
 supports a driver for the test procedure 'proc1'.
 <<Process libraries: test types>>=
   type, extends (prc_core_def_t) :: prcdef_6_t
    contains
    <<Process libraries: prcdef 6: TBP>>
   end type prcdef_6_t
 
 @ %def prcdef_6_t
 @ The process variant is named [[test_file]].
 <<Process libraries: prcdef 6: TBP>>=
   procedure, nopass :: type_string => prcdef_6_type_string
 <<Process libraries: test auxiliary>>=
   function prcdef_6_type_string () result (string)
     type(string_t) :: string
     string = "test_file"
   end function prcdef_6_type_string
 
 @ %def prcdef_6_type_string
 @ We reuse the writer [[test_writer_4]] from the previous module.
 <<Process libraries: prcdef 6: TBP>>=
   procedure :: init => prcdef_6_init
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_6_init (object)
     class(prcdef_6_t), intent(out) :: object
     allocate (test_writer_4_t :: object%writer)
     call object%writer%init_test ()
   end subroutine prcdef_6_init
 
 @ %def prcdef_6_init
 @ Nothing to write.
 <<Process libraries: prcdef 6: TBP>>=
   procedure :: write => prcdef_6_write
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_6_write (object, unit)
     class(prcdef_6_t), intent(in) :: object
     integer, intent(in) :: unit
   end subroutine prcdef_6_write
 
 @ %def prcdef_6_write
 @ Nothing to read.
 <<Process libraries: prcdef 6: TBP>>=
   procedure :: read => prcdef_6_read
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_6_read (object, unit)
     class(prcdef_6_t), intent(out) :: object
     integer, intent(in) :: unit
   end subroutine prcdef_6_read
 
 @ %def prcdef_6_read
 @ Allocate the driver with the appropriate type.
 <<Process libraries: prcdef 6: TBP>>=
   procedure :: allocate_driver => prcdef_6_allocate_driver
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_6_allocate_driver (object, driver, basename)
     class(prcdef_6_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     allocate (prctest_6_t :: driver)
   end subroutine prcdef_6_allocate_driver
 
 @ %def prcdef_6_allocate_driver
 @ This time we need code:
 <<Process libraries: prcdef 6: TBP>>=
   procedure, nopass :: needs_code => prcdef_6_needs_code
 <<Process libraries: test auxiliary>>=
   function prcdef_6_needs_code () result (flag)
     logical :: flag
     flag = .true.
   end function prcdef_6_needs_code
 
 @ %def prcdef_6_needs_code
 @ For the test case, we implement a single feature [[proc1]].
 <<Process libraries: prcdef 6: TBP>>=
   procedure, nopass :: get_features => prcdef_6_get_features
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_6_get_features (features)
     type(string_t), dimension(:), allocatable, intent(out) :: features
     allocate (features (1))
     features = [ var_str ("proc1") ]
   end subroutine prcdef_6_get_features
 
 @ %def prcdef_6_get_features
 @ The interface of the only specific feature.
 <<Process libraries: test types>>=
   abstract interface
      subroutine proc1_t (n) bind(C)
        import
        integer(c_int), intent(out) :: n
      end subroutine proc1_t
   end interface
 
 @ %def proc1_t
 @ Connect the feature [[proc1]] with the process driver.
 <<Process libraries: prcdef 6: TBP>>=
   procedure :: connect => prcdef_6_connect
 <<Process libraries: test auxiliary>>=
   subroutine prcdef_6_connect (def, lib_driver, i, proc_driver)
     class(prcdef_6_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  (prctest_6_t)
        pid = i
        fid = 1
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%proc1)
     end select
   end subroutine prcdef_6_connect
 
 @ %def prcdef_6_connect
 @
 The driver type.
 <<Process libraries: test types>>=
   type, extends (prc_core_driver_t) :: prctest_6_t
      procedure(proc1_t), nopass, pointer :: proc1 => null ()
    contains
    <<Process libraries: prctest 6: TBP>>
   end type prctest_6_t
 
 @ %def prctest_6_t
 @ Return the type name.
 <<Process libraries: prctest 6: TBP>>=
   procedure, nopass :: type_name => prctest_6_type_name
 <<Process libraries: test auxiliary>>=
   function prctest_6_type_name () result (type)
     type(string_t) :: type
     type = "test_file"
   end function prctest_6_type_name
 
 @ %def prctest_6_type_name
 @
 Here is the actual test:
 <<Process libraries: execute tests>>=
   call test (process_libraries_6, "process_libraries_6", &
        "build and load external process library", &
        u, results)
 <<Process libraries: test declarations>>=
   public :: process_libraries_6
 <<Process libraries: tests>>=
   subroutine process_libraries_6 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     type(process_def_entry_t), pointer :: entry
     class(prc_core_def_t), allocatable :: core_def
     type(os_data_t) :: os_data
     type(string_t), dimension(:), allocatable :: name_list
     type(process_constants_t) :: data
     class(prc_core_driver_t), allocatable :: proc_driver
     integer :: i
     integer(c_int) :: n
 
     write (u, "(A)")  "* Test output: process_libraries_6"
     write (u, "(A)")  "* Purpose: build and load a process library"
     write (u, "(A)")  "*          with an external (pseudo) matrix element"
     write (u, "(A)")  "*          Check single-call linking"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("proclibs6"))
     call os_data%init ()
 
     allocate (prcdef_6_t :: core_def)
     select type (core_def)
     type is (prcdef_6_t)
        call core_def%init ()
     end select
 
     allocate (entry)
     call entry%init (var_str ("proclibs6_a"), &
          model_name = var_str ("Test_model"), &
          n_in = 1, n_components = 1)
     call entry%import_component (1, n_out = 2, &
          prt_in  = new_prt_spec ([var_str ("a")]), &
          prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), &
          method  = var_str ("test"), &
          variant = core_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)")  "* Write driver source code"
     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,A,A)")  "name                      = '", &
          char (lib%get_name ()), "'"
     write (u, "(1x,A,L1)")  "is active                 = ", &
          lib%is_active ()
     write (u, "(1x,A,I0)")  "n_processes               = ", &
          lib%get_n_processes ()
     write (u, "(1x,A)", advance="no")  "processes                 ="
     call lib%get_process_id_list (name_list)
     do i = 1, size (name_list)
        write (u, "(1x,A)", advance="no")  char (name_list(i))
     end do
     write (u, *)
     write (u, "(1x,A,L1)")  "proclibs6_a is process    = ", &
          lib%contains (var_str ("proclibs6_a"))
     write (u, "(1x,A,I0)")  "proclibs6_a has index     = ", &
          lib%get_entry_index (var_str ("proclibs6_a"))
     write (u, "(1x,A,L1)")  "foobar is process         = ", &
          lib%contains (var_str ("foobar"))
     write (u, "(1x,A,I0)")  "foobar has index          = ", &
          lib%get_entry_index (var_str ("foobar"))
     write (u, "(1x,A,I0)")  "n_in(proclibs6_a)         = ", &
          lib%get_n_in (var_str ("proclibs6_a"))
     write (u, "(1x,A,A)")   "model_name(proclibs6_a)   = ", &
          char (lib%get_model_name (var_str ("proclibs6_a")))
     write (u, "(1x,A)", advance="no")  "components(proclibs6_a)   ="
     call lib%get_component_list (var_str ("proclibs6_a"), name_list)
     do i = 1, size (name_list)
        write (u, "(1x,A)", advance="no")  char (name_list(i))
     end do
     write (u, *)
 
     write (u, "(A)")
     write (u, "(A)")  "* Constants of proclibs6_a_i1:"
     write (u, "(A)")
 
     call lib%connect_process (var_str ("proclibs6_a"), 1, data, proc_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,I0))") "hel state =", data%hel_state
     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)")  "* Call feature of proclibs6_a:"
     write (u, "(A)")
 
     select type (proc_driver)
     type is (prctest_6_t)
        call proc_driver%proc1 (n)
        write (u, "(1x,A,I0)") "proc1 = ", n
     end select
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_libraries_6"
   end subroutine process_libraries_6
 
 @ %def process_libraries_6
 @
 \subsubsection{MD5 sums}
 Check MD5 sum calculation.
 <<Process libraries: execute tests>>=
   call test (process_libraries_7, "process_libraries_7", &
        "process definition list", &
        u, results)
 <<Process libraries: test declarations>>=
   public :: process_libraries_7
 <<Process libraries: tests>>=
   subroutine process_libraries_7 (u)
     integer, intent(in) :: u
     type(prc_template_t), dimension(:), allocatable :: process_core_templates
     type(process_def_entry_t), target :: entry
     class(prc_core_def_t), allocatable :: test_def
     class(prc_core_def_t), pointer :: def
 
     write (u, "(A)")  "* Test output: process_libraries_7"
     write (u, "(A)")  "* Purpose: Construct a process definition list &
          &and check MD5 sums"
     write (u, "(A)")
     write (u, "(A)")  "* Construct a process definition list"
     write (u, "(A)")  "*   Process: two components"
     write (u, "(A)")
 
     allocate (process_core_templates (1))
     allocate (prcdef_2_t :: process_core_templates(1)%core_def)
 
     call entry%init (var_str ("first"), model_name = var_str ("Test"), &
          n_in = 1, n_components = 2)
     allocate (prcdef_2_t :: test_def)
     select type (test_def)
     type is (prcdef_2_t);  test_def%data = 31
     end select
     call entry%import_component (1, n_out = 3, &
          prt_in  = new_prt_spec ([var_str ("a")]), &
          prt_out = new_prt_spec ([var_str ("b"), var_str ("c"), &
                                   var_str ("e")]), &
          method  = var_str ("test"), &
          variant = test_def)
     allocate (prcdef_2_t :: test_def)
     select type (test_def)
     type is (prcdef_2_t);  test_def%data = 42
     end select
     call entry%import_component (2, n_out = 2, &
          prt_in  = new_prt_spec ([var_str ("a")]), &
          prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), &
          method  = var_str ("test"), &
          variant = test_def)
     call entry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute MD5 sums"
     write (u, "(A)")
 
     call entry%compute_md5sum ()
     call entry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recalculate MD5 sums (should be identical)"
     write (u, "(A)")
 
     call entry%compute_md5sum ()
     call entry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Modify a component and recalculate MD5 sums"
     write (u, "(A)")
 
     def => entry%get_core_def_ptr (2)
     select type (def)
     type is (prcdef_2_t)
        def%data = 54
     end select
     call entry%compute_md5sum ()
     call entry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Modify the model and recalculate MD5 sums"
     write (u, "(A)")
 
     call entry%set_model_name (var_str ("foo"))
     call entry%compute_md5sum ()
     call entry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_libraries_7"
   end subroutine process_libraries_7
 
 @ %def process_libraries_7
 @
 Here is the actual test:
 <<Process libraries: execute tests>>=
   call test (process_libraries_8, "process_libraries_8", &
        "library status checks", &
        u, results)
 <<Process libraries: test declarations>>=
   public :: process_libraries_8
 <<Process libraries: tests>>=
   subroutine process_libraries_8 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     type(process_def_entry_t), pointer :: entry
     class(prc_core_def_t), allocatable :: core_def
     type(os_data_t) :: os_data
 
     write (u, "(A)")  "* Test output: process_libraries_8"
     write (u, "(A)")  "* Purpose: build and load a process library"
     write (u, "(A)")  "*          with an external (pseudo) matrix element"
     write (u, "(A)")  "*          Check status updates"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("proclibs8"))
     call os_data%init ()
 
     allocate (prcdef_6_t :: core_def)
     select type (core_def)
     type is (prcdef_6_t)
        call core_def%init ()
     end select
 
     allocate (entry)
     call entry%init (var_str ("proclibs8_a"), &
          model_name = var_str ("Test_model"), &
          n_in = 1, n_components = 1)
     call entry%import_component (1, n_out = 2, &
          prt_in  = new_prt_spec ([var_str ("a")]), &
          prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), &
          method  = var_str ("test"), &
          variant = core_def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure library"
     write (u, "(A)")
 
     call lib%configure (os_data)
     call lib%compute_md5sum ()
 
     call lib%test_transfer_md5sum (1, 1, 1)
 
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write makefile"
     write (u, "(A)")
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
 
     write (u, "(A)")  "* Update status"
     write (u, "(A)")
 
     call lib%update_status (os_data)
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write driver source code"
     write (u, "(A)")
     call lib%write_driver (force = .false.)
 
     write (u, "(A)")  "* Write process source code"
     write (u, "(A)")
     call lib%make_source (os_data)
 
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compile and load"
     write (u, "(A)")
 
     call lib%load (os_data)
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Append process and reconfigure"
     write (u, "(A)")
 
     allocate (prcdef_6_t :: core_def)
     select type (core_def)
     type is (prcdef_6_t)
        call core_def%init ()
     end select
 
     allocate (entry)
     call entry%init (var_str ("proclibs8_b"), &
          model_name = var_str ("Test_model"), &
          n_in = 1, n_components = 1)
     call entry%import_component (1, n_out = 2, &
          prt_in  = new_prt_spec ([var_str ("a")]), &
          prt_out = new_prt_spec ([var_str ("b"), var_str ("d")]), &
          method  = var_str ("test"), &
          variant = core_def)
     call lib%append (entry)
 
     call lib%configure (os_data)
     call lib%compute_md5sum ()
     call lib%test_transfer_md5sum (2, 2, 1)
     call lib%write_makefile (os_data, force = .false., verbose = .false.)
     call lib%write_driver (force = .false.)
 
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
     write (u, "(1x,A,I0)")  "proc2 status = ", lib%get_status (2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Update status"
     write (u, "(A)")
 
     call lib%update_status (os_data)
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
     write (u, "(1x,A,I0)")  "proc2 status = ", lib%get_status (2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write source code"
     write (u, "(A)")
 
     call lib%make_source (os_data)
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
     write (u, "(1x,A,I0)")  "proc2 status = ", lib%get_status (2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Reset status"
     write (u, "(A)")
 
     call lib%set_status (STAT_CONFIGURED, entries=.true.)
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
     write (u, "(1x,A,I0)")  "proc2 status = ", lib%get_status (2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Update status"
     write (u, "(A)")
 
     call lib%update_status (os_data)
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
     write (u, "(1x,A,I0)")  "proc2 status = ", lib%get_status (2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Partial cleanup"
     write (u, "(A)")
 
     call lib%clean (os_data, distclean = .false.)
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
     write (u, "(1x,A,I0)")  "proc2 status = ", lib%get_status (2)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Update status"
     write (u, "(A)")
 
     call lib%update_status (os_data)
     write (u, "(1x,A,L1)")  "library loaded = ", lib%is_loaded ()
     write (u, "(1x,A,I0)")  "lib status   = ", lib%get_status ()
     write (u, "(1x,A,I0)")  "proc1 status = ", lib%get_status (1)
     write (u, "(1x,A,I0)")  "proc2 status = ", lib%get_status (2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Complete cleanup"
 
     call lib%clean (os_data, distclean = .true.)
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_libraries_8"
   end subroutine process_libraries_8
 
 @ %def process_libraries_8
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process Library Stacks}
 
 For storing and handling multiple libraries, we define process library stacks.
 These are ordinary stacks where new entries are pushed onto the top.
 <<[[prclib_stacks.f90]]>>=
 <<File header>>
 
 module prclib_stacks
 
 <<Use strings>>
   use io_units
   use format_utils, only: write_separator
   use process_libraries
 
 <<Standard module head>>
 
 <<Prclib stacks: public>>
 
 <<Prclib stacks: types>>
 
 contains
 
 <<Prclib stacks: procedures>>
 
 end module prclib_stacks
 @ %def prclib_stacks
 @
 \subsection{The stack entry type}
 A stack entry is a process library object, augmented by a pointer to the
 next entry.  We do not need specific methods, all relevant methods are
 inherited.
 
 On higher level, process libraries should be prepared as process entry objects.
 <<Prclib stacks: public>>=
   public :: prclib_entry_t
 <<Prclib stacks: types>>=
   type, extends (process_library_t) :: prclib_entry_t
      type(prclib_entry_t), pointer :: next => null ()
   end type prclib_entry_t
 
 @ %def prclib_entry_t
 @
 \subsection{The prclib 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.
 <<Prclib stacks: public>>=
   public :: prclib_stack_t
 <<Prclib stacks: types>>=
   type :: prclib_stack_t
      integer :: n = 0
      type(prclib_entry_t), pointer :: first => null ()
    contains
    <<Prclib stacks: prclib stack: TBP>>
   end type prclib_stack_t
 
 @ %def prclib_stack_t
 @ Finalizer.  Iteratively deallocate the stack entries.  The resulting
 empty stack can be immediately recycled, if necessary.
 <<Prclib stacks: prclib stack: TBP>>=
   procedure :: final => prclib_stack_final
 <<Prclib stacks: procedures>>=
   subroutine prclib_stack_final (object)
     class(prclib_stack_t), intent(inout) :: object
     type(prclib_entry_t), pointer :: lib
     do while (associated (object%first))
        lib => object%first
        object%first => lib%next
        call lib%final ()
        deallocate (lib)
     end do
     object%n = 0
   end subroutine prclib_stack_final
 
 @ %def prclib_stack_final
 @ Output.  The entries on the stack will be ordered LIFO, i.e., backwards.
 <<Prclib stacks: prclib stack: TBP>>=
   procedure :: write => prclib_stack_write
 <<Prclib stacks: procedures>>=
   subroutine prclib_stack_write (object, unit, libpath)
     class(prclib_stack_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: libpath
     type(prclib_entry_t), pointer :: lib
     integer :: u
     u = given_output_unit (unit)
     call write_separator (u, 2)
     select case (object%n)
     case (0)
        write (u, "(1x,A)")  "Process library stack: [empty]"
     case default
        write (u, "(1x,A)")  "Process library stack:"
        lib => object%first
        do while (associated (lib))
           call write_separator (u)
           call lib%write (u, libpath)
           lib => lib%next
        end do
     end select
     call write_separator (u, 2)
   end subroutine prclib_stack_write
 
 @ %def prclib_stack_write
 @
 \subsection{Operating on Stacks}
 We take a library entry pointer and push it onto the stack.  The previous
 pointer is nullified.  Subsequently, the library entry is `owned' by the
 stack and will be finalized when the stack is deleted.
 <<Prclib stacks: prclib stack: TBP>>=
   procedure :: push => prclib_stack_push
 <<Prclib stacks: procedures>>=
   subroutine prclib_stack_push (stack, lib)
     class(prclib_stack_t), intent(inout) :: stack
     type(prclib_entry_t), intent(inout), pointer :: lib
     lib%next => stack%first
     stack%first => lib
     lib => null ()
     stack%n = stack%n + 1
   end subroutine prclib_stack_push
 
 @ %def prclib_stack_push
 @
 \subsection{Accessing Contents}
 Return a pointer to the topmost stack element.  The result type is
 just the bare [[process_library_t]].  There is no [[target]] attribute
 required since the stack elements are allocated via pointers.
 <<Prclib stacks: prclib stack: TBP>>=
   procedure :: get_first_ptr => prclib_stack_get_first_ptr
 <<Prclib stacks: procedures>>=
   function prclib_stack_get_first_ptr (stack) result (ptr)
     class(prclib_stack_t), intent(in) :: stack
     type(process_library_t), pointer :: ptr
     if (associated (stack%first)) then
        ptr => stack%first%process_library_t
     else
        ptr => null ()
     end if
   end function prclib_stack_get_first_ptr
 
 @ %def prclib_stack_get_first_ptr
 @ Return a complete list of the libraries (names) in the stack.  The list is
 in the order in which the elements got pushed onto the stack, so the 'first'
 entry is listed last.
 <<Prclib stacks: prclib stack: TBP>>=
   procedure :: get_names => prclib_stack_get_names
 <<Prclib stacks: procedures>>=
   subroutine prclib_stack_get_names (stack, libname)
     class(prclib_stack_t), intent(in) :: stack
     type(string_t), dimension(:), allocatable, intent(out) :: libname
     type(prclib_entry_t), pointer :: lib
     integer :: i
     allocate (libname (stack%n))
     i = stack%n
     lib => stack%first
     do while (associated (lib))
        libname(i) = lib%get_name ()
        i = i - 1
        lib => lib%next
     end do
   end subroutine prclib_stack_get_names
 
 @ %def prclib_stack_get_names
 @ Return a pointer to the library with given name.
 <<Prclib stacks: prclib stack: TBP>>=
   procedure :: get_library_ptr => prclib_stack_get_library_ptr
 <<Prclib stacks: procedures>>=
   function prclib_stack_get_library_ptr (stack, libname) result (ptr)
     class(prclib_stack_t), intent(in) :: stack
     type(string_t), intent(in) :: libname
     type(process_library_t), pointer :: ptr
     type(prclib_entry_t), pointer :: current
     current => stack%first
     do while (associated (current))
        if (current%get_name () == libname) then
           ptr => current%process_library_t
           return
        end if
        current => current%next
     end do
     ptr => null ()
   end function prclib_stack_get_library_ptr
 
 @ %def prclib_stack_get_library_ptr
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[prclib_stacks_ut.f90]]>>=
 <<File header>>
 
 module prclib_stacks_ut
   use unit_tests
   use prclib_stacks_uti
 
 <<Standard module head>>
 
 <<Prclib stacks: public test>>
 
 contains
 
 <<Prclib stacks: test driver>>
 
 end module prclib_stacks_ut
 @ %def prclib_stacks_ut
 @
 <<[[prclib_stacks_uti.f90]]>>=
 <<File header>>
 
 module prclib_stacks_uti
 
 <<Use strings>>
 
   use prclib_stacks
 
 <<Standard module head>>
 
 <<Prclib stacks: test declarations>>
 
 contains
 
 <<Prclib stacks: tests>>
 
 end module prclib_stacks_uti
 @ %def prclib_stacks_ut
 @ API: driver for the unit tests below.
 <<Prclib stacks: public test>>=
   public :: prclib_stacks_test
 <<Prclib stacks: test driver>>=
   subroutine prclib_stacks_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Prclib stacks: execute tests>>
   end subroutine prclib_stacks_test
 
 @ %def prclib_stacks_test
 @
 \subsubsection{Write an empty process library stack}
 The most trivial test is to write an uninitialized process library stack.
 <<Prclib stacks: execute tests>>=
   call test (prclib_stacks_1, "prclib_stacks_1", &
        "write an empty process library stack", &
        u, results)
 <<Prclib stacks: test declarations>>=
   public :: prclib_stacks_1
 <<Prclib stacks: tests>>=
   subroutine prclib_stacks_1 (u)
     integer, intent(in) :: u
     type(prclib_stack_t) :: stack
 
     write (u, "(A)")  "* Test output: prclib_stacks_1"
     write (u, "(A)")  "*   Purpose: display an empty process library stack"
     write (u, "(A)")
 
     call stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prclib_stacks_1"
 
   end subroutine prclib_stacks_1
 
 @ %def prclib_stacks_1
 @
 \subsubsection{Fill a process library stack}
 Fill a process library stack with two (identical) processes.
 <<Prclib stacks: execute tests>>=
   call test (prclib_stacks_2, "prclib_stacks_2", &
        "fill a process library stack", &
        u, results)
 <<Prclib stacks: test declarations>>=
   public :: prclib_stacks_2
 <<Prclib stacks: tests>>=
   subroutine prclib_stacks_2 (u)
     integer, intent(in) :: u
     type(prclib_stack_t) :: stack
     type(prclib_entry_t), pointer :: lib
 
     write (u, "(A)")  "* Test output: prclib_stacks_2"
     write (u, "(A)")  "*   Purpose: fill a process library stack"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize two (empty) libraries &
          &and push them on the stack"
     write (u, "(A)")
 
     allocate (lib)
     call lib%init (var_str ("lib1"))
     call stack%push (lib)
 
     allocate (lib)
     call lib%init (var_str ("lib2"))
     call stack%push (lib)
 
     call stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call stack%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prclib_stacks_2"
 
   end subroutine prclib_stacks_2
 
 @ %def prclib_stacks_2
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Trivial matrix element for tests}
 
 For the purpose of testing the workflow, we implement here two matrix
 elements with the simplest possible structure.
 
 This matrix element generator can only generate a single scattering
 process and a single decay process.  The scattering process is a
 quartic interaction of a massless, neutral and colorless scalar [[s]]
 with unit coupling results in a trivial $2\to 2$ scattering process.
 The matrix element is implemented internally, so we do not need the
 machinery of external process libraries.  The decay process is a decay
 of [[s]] into a pair of colored fermions [[f]].
 
 <<[[prc_test.f90]]>>=
 <<File header>>
 
 module prc_test
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use kinds>>
 <<Use strings>>
   use os_interface
   use process_constants
   use prclib_interfaces
   use prc_core_def
   use particle_specifiers, only: new_prt_spec
   use process_libraries
 
 <<Standard module head>>
 
 <<Test ME: public>>
 
 <<Test ME: types>>
 
 contains
 
 <<Test ME: procedures>>
 
 end module prc_test
 @ %def prc_test
 @
 \subsection{Process definition}
 For the process definition we implement an extension of the
 [[prc_core_def_t]] abstract type.
 <<Test ME: public>>=
   public :: prc_test_def_t
 <<Test ME: types>>=
   type, extends (prc_core_def_t) :: prc_test_def_t
      type(string_t) :: model_name
      type(string_t), dimension(:), allocatable :: prt_in
      type(string_t), dimension(:), allocatable :: prt_out
    contains
    <<Test ME: test me def: TBP>>
   end type prc_test_def_t
 
 @ %def prc_test_def_t
 <<Test ME: test me def: TBP>>=
   procedure, nopass :: type_string => prc_test_def_type_string
 <<Test ME: procedures>>=
   function prc_test_def_type_string () result (string)
     type(string_t) :: string
     string = "test_me"
   end function prc_test_def_type_string
 
 @ %def prc_test_def_type_string
 @ There is no 'feature' here since there is no external code.
 <<Test ME: test me def: TBP>>=
   procedure, nopass :: get_features => prc_test_def_get_features
 <<Test ME: procedures>>=
   subroutine prc_test_def_get_features (features)
     type(string_t), dimension(:), allocatable, intent(out) :: features
     allocate (features (0))
   end subroutine prc_test_def_get_features
 
 @ %def prc_test_def_get_features
 @ Initialization: set some data (not really useful).
 <<Test ME: test me def: TBP>>=
   procedure :: init => prc_test_def_init
 <<Test ME: procedures>>=
   subroutine prc_test_def_init (object, model_name, prt_in, prt_out)
     class(prc_test_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
     object%model_name = model_name
     allocate (object%prt_in (size (prt_in)))
     object%prt_in = prt_in
     allocate (object%prt_out (size (prt_out)))
     object%prt_out = prt_out
   end subroutine prc_test_def_init
 
 @ %def prc_test_def_init
 @ Write/read process- and method-specific data.  (No-op)
 <<Test ME: test me def: TBP>>=
   procedure :: write => prc_test_def_write
 <<Test ME: procedures>>=
   subroutine prc_test_def_write (object, unit)
     class(prc_test_def_t), intent(in) :: object
     integer, intent(in) :: unit
   end subroutine prc_test_def_write
 
 @ %def prc_test_def_write
 @
 <<Test ME: test me def: TBP>>=
   procedure :: read => prc_test_def_read
 <<Test ME: procedures>>=
   subroutine prc_test_def_read (object, unit)
     class(prc_test_def_t), intent(out) :: object
     integer, intent(in) :: unit
   end subroutine prc_test_def_read
 
 @ %def prc_test_def_read
 @ Allocate the driver for test ME matrix elements.  We get the
 actual component ID (basename), and we can transfer all
 process-specific data from the process definition.
 <<Test ME: test me def: TBP>>=
   procedure :: allocate_driver => prc_test_def_allocate_driver
 <<Test ME: procedures>>=
   subroutine prc_test_def_allocate_driver (object, driver, basename)
     class(prc_test_def_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     allocate (prc_test_t :: driver)
     select type (driver)
     type is (prc_test_t)
        driver%id = basename
        driver%model_name = object%model_name
        select case (size (object%prt_in))
        case (1);  driver%scattering = .false.
        case (2);  driver%scattering = .true.
        end select
     end select
   end subroutine prc_test_def_allocate_driver
 
 @ %def prc_test_def_allocate_driver
 @ Nothing to connect.  This subroutine will not be called.
 <<Test ME: test me def: TBP>>=
   procedure :: connect => prc_test_def_connect
 <<Test ME: procedures>>=
   subroutine prc_test_def_connect (def, lib_driver, i, proc_driver)
     class(prc_test_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
   end subroutine prc_test_def_connect
 
 @ %def prc_test_def_connect
 @
 \subsection{Driver}
 <<Test ME: public>>=
   public :: prc_test_t
 <<Test ME: types>>=
   type, extends (process_driver_internal_t) :: prc_test_t
      type(string_t) :: id
      type(string_t) :: model_name
      logical :: scattering = .true.
    contains
    <<Test ME: test me driver: TBP>>
   end type prc_test_t
 
 @ %def prc_test_t
 @ In contrast to generic matrix-element implementations, we can
 hard-wire the amplitude method as a type-bound procedure.
 <<Test ME: test me driver: TBP>>=
   procedure, nopass :: get_amplitude => prc_test_get_amplitude
 <<Test ME: procedures>>=
   function prc_test_get_amplitude (p) result (amp)
     complex(default) :: amp
     real(default), dimension(:,:), intent(in) :: p
     amp = 1
   end function prc_test_get_amplitude
 
 @ %def prc_test_get_amplitude
 @ The reported type is the same as for the [[prc_test_def_t]] type.
 <<Test ME: test me driver: TBP>>=
   procedure, nopass :: type_name => prc_test_type_name
 <<Test ME: procedures>>=
   function prc_test_type_name () result (string)
     type(string_t) :: string
     string = "test_me"
   end function prc_test_type_name
 
 @ %def prc_test_type_name
 @ Fill process constants.
 <<Test ME: test me driver: TBP>>=
   procedure :: fill_constants => prc_test_fill_constants
 <<Test ME: procedures>>=
   subroutine prc_test_fill_constants (driver, data)
     class(prc_test_t), intent(in) :: driver
     type(process_constants_t), intent(out) :: data
     data%id = driver%id
     data%model_name = driver%model_name
     if (driver%scattering) then
        data%n_in  = 2
        data%n_out = 2
        data%n_flv = 1
        data%n_hel = 1
        data%n_col = 1
        data%n_cin = 2
        data%n_cf  = 1
        allocate (data%flv_state (4, 1))
        data%flv_state = 25
        allocate (data%hel_state (4, 1))
        data%hel_state = 0
        allocate (data%col_state (2, 4, 1))
        data%col_state = 0
        allocate (data%ghost_flag (4, 1))
        data%ghost_flag = .false.
        allocate (data%color_factors (1))
        data%color_factors = 1
        allocate (data%cf_index (2, 1))
        data%cf_index = 1
     else
        data%n_in  = 1
        data%n_out = 2
        data%n_flv = 1
        data%n_hel = 2
        data%n_col = 1
        data%n_cin = 2
        data%n_cf  = 1
        allocate (data%flv_state (3, 1))
        data%flv_state(:,1) = [25, 6, -6]
        allocate (data%hel_state (3, 2))
        data%hel_state(:,1) = [0, 1,-1]
        data%hel_state(:,2) = [0,-1, 1]
        allocate (data%col_state (2, 3, 1))
        data%col_state = reshape ([0,0, 1,0, 0,-1], [2,3,1])
        allocate (data%ghost_flag (3, 1))
        data%ghost_flag = .false.
        allocate (data%color_factors (1))
        data%color_factors = 3
        allocate (data%cf_index (2, 1))
        data%cf_index = 1
     end if
   end subroutine prc_test_fill_constants
 
 @ %def prc_test_fill_constants
 @
 \subsection{Shortcut}
 Since this module is there for testing purposes, we set up a
 subroutine that does all the work at once: create a library with the
 two processes (scattering and decay), configure and load, and set up
 the driver.
 <<Test ME: public>>=
   public :: prc_test_create_library
 <<Test ME: procedures>>=
   subroutine prc_test_create_library &
        (libname, lib, scattering, decay, procname1, procname2)
     type(string_t), intent(in) :: libname
     type(process_library_t), intent(out) :: lib
     logical, intent(in), optional :: scattering, decay
     type(string_t), intent(in), optional :: procname1, procname2
     type(string_t) :: model_name, procname
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     logical :: sca, dec
     sca = .true.;   if (present (scattering))  sca = scattering
     dec = .false.;  if (present (decay))       dec = decay
 
     call os_data%init ()
     call lib%init (libname)
     model_name = "Test"
 
     if (sca) then
        if (present (procname1)) then
           procname = procname1
        else
           procname = libname
        end if
        allocate (prt_in (2), prt_out (2))
        prt_in  = [var_str ("s"), var_str ("s")]
        prt_out = [var_str ("s"), var_str ("s")]
        allocate (prc_test_def_t :: def)
        select type (def)
        type is (prc_test_def_t)
           call def%init (model_name, prt_in, prt_out)
        end select
        allocate (entry)
        call entry%init (procname, 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 ("test_me"), &
             variant = def)
        call lib%append (entry)
     end if
 
     if (dec) then
        if (present (procname2)) then
           procname = procname2
        else
           procname = libname
        end if
        if (allocated (prt_in))  deallocate (prt_in, prt_out)
        allocate (prt_in (1), prt_out (2))
        prt_in  = [var_str ("s")]
        prt_out = [var_str ("f"), var_str ("fbar")]
        allocate (prc_test_def_t :: def)
        select type (def)
        type is (prc_test_def_t)
           call def%init (model_name, prt_in, prt_out)
        end select
        allocate (entry)
        call entry%init (procname, model_name = model_name, &
             n_in = 1, 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 ("test_decay"), &
             variant = def)
        call lib%append (entry)
     end if
 
     call lib%configure (os_data)
     call lib%load (os_data)
   end subroutine prc_test_create_library
 
 @ %def prc_test_create_library
 @
 \subsection{Unit Test}
 Test module, followed by the corresponding implementation module.
 <<[[prc_test_ut.f90]]>>=
 <<File header>>
 
 module prc_test_ut
   use unit_tests
   use prc_test_uti
 
 <<Standard module head>>
 
 <<Test ME: public test>>
 
 contains
 
 <<Test ME: test driver>>
 
 end module prc_test_ut
 @ %def prc_test_ut
 @
 <<[[prc_test_uti.f90]]>>=
 <<File header>>
 
 module prc_test_uti
 
 <<Use kinds>>
 <<Use strings>>
   use os_interface
   use particle_specifiers, only: new_prt_spec
   use process_constants
   use prc_core_def
   use process_libraries
 
   use prc_test
 
 <<Standard module head>>
 
 <<Test ME: test declarations>>
 
 contains
 
 <<Test ME: tests>>
 
 end module prc_test_uti
 @ %def prc_test_ut
 @ API: driver for the unit tests below.
 <<Test ME: public test>>=
   public :: prc_test_test
 <<Test ME: test driver>>=
   subroutine prc_test_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Test ME: execute tests>>
 end subroutine prc_test_test
 
 @ %def prc_test_test
 @
 \subsubsection{Generate and load the scattering process}
 The process is $s s \to s s$, where $s$ is a trivial scalar particle,
 for vanishing mass and unit coupling.  We initialize the process,
 build the library, and compute the particular matrix element for
 momenta of unit energy and right-angle scattering.  (The scattering is
 independent of angle.)  The matrix element is equal to unity.
 <<Test ME: execute tests>>=
   call test (prc_test_1, "prc_test_1", &
        "build and load trivial process", &
        u, results)
 <<Test ME: test declarations>>=
   public :: prc_test_1
 <<Test ME: tests>>=
   subroutine prc_test_1 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(process_library_t) :: lib
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
     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
     real(default), dimension(0:3,4) :: p
     integer :: i
 
     write (u, "(A)")  "* Test output: prc_test_1"
     write (u, "(A)")  "*   Purpose: create a trivial process"
     write (u, "(A)")  "*            build a library and &
          &access the matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call os_data%init ()
     call lib%init (var_str ("prc_test1"))
 
     model_name = "Test"
     allocate (prt_in (2), prt_out (2))
     prt_in  = [var_str ("s"), var_str ("s")]
     prt_out = [var_str ("s"), var_str ("s")]
 
     allocate (prc_test_def_t :: def)
     select type (def)
     type is (prc_test_def_t)
        call def%init (model_name, prt_in, prt_out)
     end select
     allocate (entry)
     call entry%init (var_str ("prc_test1_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 ("test_me"), &
          variant = def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure library"
     write (u, "(A)")
     call lib%configure (os_data)
 
     write (u, "(A)")  "* Load library"
     write (u, "(A)")
     call lib%load (os_data)
 
     call lib%write (u)
 
     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 prc_test1_a_i1:"
     write (u, "(A)")
 
     call lib%connect_process (var_str ("prc_test1_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)
     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 kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          1.0_default, 0.0_default, 0.0_default, 1.0_default, &
          1.0_default, 0.0_default, 0.0_default,-1.0_default, &
          1.0_default, 1.0_default, 0.0_default, 0.0_default, &
          1.0_default,-1.0_default, 0.0_default, 0.0_default &
          ], [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)
     type is (prc_test_t)
        write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p))
     end select
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_test_1"
 
   end subroutine prc_test_1
 
 @ %def prc_test_1
 @
 \subsubsection{Shortcut}
 This is identical to the previous test, but we create the library be a single
 command.  This is handy for other modules which use the test process.
 <<Test ME: execute tests>>=
   call test (prc_test_2, "prc_test_2", &
        "build and load trivial process using shortcut", &
        u, results)
 <<Test ME: test declarations>>=
   public :: prc_test_2
 <<Test ME: tests>>=
   subroutine prc_test_2 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     class(prc_core_driver_t), allocatable :: driver
     type(process_constants_t) :: data
     real(default), dimension(0:3,4) :: p
 
     write (u, "(A)")  "* Test output: prc_test_2"
     write (u, "(A)")  "*   Purpose: create a trivial process"
     write (u, "(A)")  "*            build a library and &
          &access the matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a process library with one entry"
 
     call prc_test_create_library (var_str ("prc_test2"), lib)
     call lib%connect_process (var_str ("prc_test2"), 1, data, driver)
 
     p = reshape ([ &
          1.0_default, 0.0_default, 0.0_default, 1.0_default, &
          1.0_default, 0.0_default, 0.0_default,-1.0_default, &
          1.0_default, 1.0_default, 0.0_default, 0.0_default, &
          1.0_default,-1.0_default, 0.0_default, 0.0_default &
          ], [4,4])
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute matrix element:"
     write (u, "(A)")
 
     select type (driver)
     type is (prc_test_t)
        write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p))
     end select
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_test_2"
 
   end subroutine prc_test_2
 
 @ %def prc_test_2
 @
 \subsubsection{Generate and load the decay process}
 The process is $s \to f\bar f$, where $s$ is a trivial scalar particle
 and $f$ is a colored fermion.  We initialize the process,
 build the library, and compute the particular matrix element for a
 fixed momentum configuration.  (The decay is
 independent of angle.)  The matrix element is equal to unity.
 <<Test ME: execute tests>>=
   call test (prc_test_3, "prc_test_3", &
        "build and load trivial decay", &
        u, results)
 <<Test ME: test declarations>>=
   public :: prc_test_3
 <<Test ME: tests>>=
   subroutine prc_test_3 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(process_library_t) :: lib
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
     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
     real(default), dimension(0:3,3) :: p
     integer :: i
 
     write (u, "(A)")  "* Test output: prc_test_3"
     write (u, "(A)")  "*   Purpose: create a trivial decay process"
     write (u, "(A)")  "*            build a library and &
          &access the matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call os_data%init ()
     call lib%init (var_str ("prc_test3"))
 
     model_name = "Test"
     allocate (prt_in (1), prt_out (2))
     prt_in  = [var_str ("s")]
     prt_out = [var_str ("f"), var_str ("F")]
 
     allocate (prc_test_def_t :: def)
     select type (def)
     type is (prc_test_def_t)
        call def%init (model_name, prt_in, prt_out)
     end select
     allocate (entry)
     call entry%init (var_str ("prc_test3_a"), model_name = model_name, &
          n_in = 1, 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 ("test_me"), &
          variant = def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure library"
     write (u, "(A)")
     call lib%configure (os_data)
 
     write (u, "(A)")  "* Load library"
     write (u, "(A)")
     call lib%load (os_data)
 
     call lib%write (u)
 
     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 prc_test3_a_i1:"
     write (u, "(A)")
 
     call lib%connect_process (var_str ("prc_test3_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)
     write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,2)
     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 kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          125._default, 0.0_default, 0.0_default, 0.0_default, &
          62.5_default, 0.0_default, 0.0_default, 62.5_default, &
          62.5_default, 0.0_default, 0.0_default,-62.5_default &
          ], [4,3])
     do i = 1, 3
        write (u, "(2x,A,I0,A,4(1x,F8.4))")  "p", i, " =", p(:,i)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute matrix element:"
     write (u, "(A)")
 
     select type (driver)
     type is (prc_test_t)
        write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p))
     end select
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_test_3"
 
   end subroutine prc_test_3
 
 @ %def prc_test_3
 @
 \subsubsection{Shortcut}
 This is identical to the previous test, but we create the library be a single
 command.  This is handy for other modules which use the test process.
 <<Test ME: execute tests>>=
   call test (prc_test_4, "prc_test_4", &
        "build and load trivial decay using shortcut", &
        u, results)
 <<Test ME: test declarations>>=
   public :: prc_test_4
 <<Test ME: tests>>=
   subroutine prc_test_4 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     class(prc_core_driver_t), allocatable :: driver
     type(process_constants_t) :: data
     real(default), dimension(0:3,3) :: p
 
     write (u, "(A)")  "* Test output: prc_test_4"
     write (u, "(A)")  "*   Purpose: create a trivial decay process"
     write (u, "(A)")  "*            build a library and &
          &access the matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a process library with one entry"
 
     call prc_test_create_library (var_str ("prc_test4"), lib, &
          scattering=.false., decay=.true.)
     call lib%connect_process (var_str ("prc_test4"), 1, data, driver)
 
     p = reshape ([ &
          125._default, 0.0_default, 0.0_default, 0.0_default, &
          62.5_default, 0.0_default, 0.0_default, 62.5_default, &
          62.5_default, 0.0_default, 0.0_default,-62.5_default &
          ], [4,3])
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute matrix element:"
     write (u, "(A)")
 
     select type (driver)
     type is (prc_test_t)
        write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p))
     end select
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_test_4"
 
   end subroutine prc_test_4
 
 @ %def prc_test_4
Index: trunk/src/blha/blha.nw
===================================================================
--- trunk/src/blha/blha.nw	(revision 8444)
+++ trunk/src/blha/blha.nw	(revision 8445)
@@ -1,3404 +1,3447 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: matrix elements and process libraries
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{BLHA Interface}
 \includemodulegraph{blha}
 
 The code in this chapter implements support for the BLHA record that
 communicates data for NLO processes.
 
 These are the modules:
 \begin{description}
 \item[blha\_config]
 \item[blha\_interface]
 \item[blha\_driver]
 \end{description}
 
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Module definition}
 
 These modules implement the communication with one loop matrix element providers
 according to the Binoth LesHouches Accord Interface. The actual matrix
 element(s) are loaded as a dynamic library.
 
 This module defines the common OLP-interfaces defined through the Binoth Les-Houches
 accord.
 
 <<[[blha_olp_interfaces.f90]]>>=
 <<File header>>
 
 module blha_olp_interfaces
 
   use, intrinsic :: iso_c_binding !NODEP!
   use, intrinsic :: iso_fortran_env
 
   use kinds
 <<Use strings>>
 <<Use debug>>
   use constants
   use numeric_utils, only: vanishes
   use numeric_utils, only: extend_integer_array, crop_integer_array
   use io_units
   use string_utils
   use physics_defs
   use diagnostics
   use os_interface
   use lorentz
   use sm_qcd
   use interactions
   use flavors
   use model_data
   use pdg_arrays, only: is_gluon, is_quark
 
   use prclib_interfaces
   use process_libraries
   use prc_core_def
   use prc_core
 
   use prc_external
 
   use blha_config
 
 <<Standard module head>>
 
 <<BLHA OLP interfaces: public>>
 
 <<BLHA OLP interfaces: public parameters>>
 
 <<BLHA OLP interfaces: parameters>>
 
 <<BLHA OLP interfaces: types>>
 
 <<BLHA OLP interfaces: interfaces>>
 
 contains
 
 <<BLHA OLP interfaces: procedures>>
 
 end module blha_olp_interfaces
 
 @ %def module blha_olp_interfaces
 @
 <<BLHA OLP interfaces: public>>=
   public :: blha_template_t
 <<BLHA OLP interfaces: types>>=
   type :: blha_template_t
     integer :: I_BORN = 0
     integer :: I_REAL = 1
     integer :: I_LOOP = 2
     integer :: I_SUB = 3
     integer :: I_DGLAP = 4
     logical, dimension(0:4) :: compute_component
     logical :: include_polarizations = .false.
     logical :: switch_off_muon_yukawas = .false.
     logical :: use_internal_color_correlations = .true.
     real(default) :: external_top_yukawa = -1._default
     integer :: ew_scheme
     integer :: loop_method = BLHA_MODE_GENERIC
   contains
   <<BLHA OLP interfaces: blha template: TBP>>
   end type blha_template_t
 
 @ %def blha_template_t
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: write => blha_template_write
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_template_write (blha_template, unit)
     class(blha_template_t), intent(in) :: blha_template
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,"(A,4(L1))") "Compute components: ", &
          blha_template%compute_component
     write (u,"(A,L1)") "Include polarizations: ", &
          blha_template%include_polarizations
     write (u,"(A,L1)") "Switch off muon yukawas: ", &
          blha_template%switch_off_muon_yukawas
     write (u,"(A,L1)") "Use internal color correlations: ", &
          blha_template%use_internal_color_correlations
   end subroutine blha_template_write
 
 @ %def blha_template_write
 @ Compute the total number of used helicity states for the given particle PDG
 codes, given a model.  Applies only if polarization is supported.  This
 yields the [[n_hel]] value as required below.
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: get_n_hel => blha_template_get_n_hel
 <<BLHA OLP interfaces: procedures>>=
   function blha_template_get_n_hel (blha_template, pdg, model) result (n_hel)
     class(blha_template_t), intent(in) :: blha_template
     integer, dimension(:), intent(in) :: pdg
     class(model_data_t), intent(in), target :: model
     integer :: n_hel
     type(flavor_t) :: flv
     integer :: f
     n_hel = 1
     if (blha_template%include_polarizations) then
        do f = 1, size (pdg)
           call flv%init (pdg(f), model)
           n_hel = n_hel * flv%get_multiplicity ()
        end do
     end if
   end function blha_template_get_n_hel
 
 @ %def blha_template_get_n_hel
 @
 <<BLHA OLP interfaces: parameters>>=
   integer, parameter :: I_ALPHA_0 = 1
   integer, parameter :: I_GF = 2
   integer, parameter :: I_ALPHA_MZ = 3
   integer, parameter :: I_ALPHA_INTERNAL = 4
   integer, parameter :: I_SW2 = 5
 
 <<BLHA OLP interfaces: public>>=
   public :: prc_blha_t
 <<BLHA OLP interfaces: types>>=
   type, abstract, extends (prc_external_t) :: prc_blha_t
     integer :: n_particles
     integer :: n_hel
     integer :: n_proc
     integer, dimension(:, :), allocatable :: i_tree, i_spin_c, i_color_c
     integer, dimension(:, :), allocatable :: i_virt
     integer, dimension(:, :), allocatable :: i_hel
     logical, dimension(5) :: ew_parameter_mask
     integer :: sqme_tree_pos
   contains
   <<BLHA OLP interfaces: prc blha: TBP>>
   end type prc_blha_t
 
 @ %def prc_blha_t
 @
 Obviously, this process-core type uses the BLHA interface.
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure, nopass :: uses_blha => prc_blha_uses_blha
 <<BLHA OLP interfaces: procedures>>=
   function prc_blha_uses_blha () result (flag)
     logical :: flag
     flag = .true.
   end function prc_blha_uses_blha
 
 @ %def prc_blha_uses_blha
 @
 <<BLHA OLP interfaces: public>>=
   public :: blha_driver_t
 <<BLHA OLP interfaces: types>>=
   type, abstract, extends (prc_external_driver_t) :: blha_driver_t
     type(string_t) :: contract_file
     type(string_t) :: nlo_suffix
     logical :: include_polarizations = .false.
     logical :: switch_off_muon_yukawas = .false.
     real(default) :: external_top_yukawa = -1.0
     procedure(olp_start),nopass,  pointer :: &
          blha_olp_start => null ()
     procedure(olp_eval), nopass, pointer :: &
          blha_olp_eval => null()
     procedure(olp_info), nopass, pointer :: &
          blha_olp_info => null ()
     procedure(olp_set_parameter), nopass, pointer :: &
          blha_olp_set_parameter => null ()
     procedure(olp_eval2), nopass, pointer :: &
          blha_olp_eval2 => null ()
     procedure(olp_option), nopass, pointer :: &
          blha_olp_option => null ()
     procedure(olp_polvec), nopass, pointer :: &
          blha_olp_polvec => null ()
     procedure(olp_finalize), nopass, pointer :: &
          blha_olp_finalize => null ()
     procedure(olp_print_parameter), nopass, pointer :: &
          blha_olp_print_parameter => null ()
   contains
   <<BLHA OLP interfaces: blha driver: TBP>>
   end type blha_driver_t
 
 @
 @ %def blha_driver_t
 <<BLHA OLP interfaces: public>>=
   public :: prc_blha_writer_t
 <<BLHA OLP interfaces: types>>=
   type, abstract, extends (prc_external_writer_t) :: prc_blha_writer_t
     type(blha_configuration_t) :: blha_cfg
   contains
   <<BLHA OLP interfaces: blha writer: TBP>>
   end type prc_blha_writer_t
 
 @
 @ %def prc_blha_writer_t
 <<BLHA OLP interfaces: public>>=
   public :: blha_def_t
 <<BLHA OLP interfaces: types>>=
   type, abstract, extends (prc_external_def_t) :: blha_def_t
     type(string_t) :: suffix
   contains
   <<BLHA OLP interfaces: blha def: TBP>>
   end type blha_def_t
 
 @ %def blha_def_t
 @
 <<BLHA OLP interfaces: public>>=
   public :: blha_state_t
 <<BLHA OLP interfaces: types>>=
   type, abstract, extends (prc_external_state_t) :: blha_state_t
   contains
   <<BLHA OLP interfaces: blha state: TBP>>
   end type blha_state_t
 
 @ %def blha_state_t
 @
 <<BLHA OLP interfaces: blha state: TBP>>=
   procedure :: reset_new_kinematics => blha_state_reset_new_kinematics
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_state_reset_new_kinematics (object)
     class(blha_state_t), intent(inout) :: object
     object%new_kinematics = .true.
   end subroutine blha_state_reset_new_kinematics
 
 @ %def blha_state_reset_new_kinematics
 @
 <<BLHA OLP interfaces: public parameters>>=
   integer, parameter, public :: OLP_PARAMETER_LIMIT = 10
   integer, parameter, public :: OLP_MOMENTUM_LIMIT = 50
   integer, parameter, public :: OLP_RESULTS_LIMIT = 60
 
 <<BLHA OLP interfaces: public>>=
   public :: olp_start
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_start (contract_file_name, ierr) bind (C,name = "OLP_Start")
       import
       character(kind = c_char, len = 1), intent(in) :: contract_file_name
       integer(kind = c_int), intent(out) :: ierr
     end subroutine olp_start
   end interface
 
 @ %def olp_start_interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: olp_eval
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_eval (label, momenta, mu, parameters, res) &
            bind (C, name = "OLP_EvalSubProcess")
       import
       integer(kind = c_int), value, intent(in) :: label
       real(kind = c_double), value, intent(in) :: mu
       real(kind = c_double), dimension(OLP_MOMENTUM_LIMIT), intent(in) :: &
            momenta
       real(kind = c_double), dimension(OLP_PARAMETER_LIMIT), intent(in) :: &
            parameters
       real(kind = c_double), dimension(OLP_RESULTS_LIMIT), intent(out) :: res
     end subroutine olp_eval
   end interface
 
 @ %def olp_eval interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: olp_info
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_info (olp_file, olp_version, message) bind(C)
       import
       character(kind = c_char), intent(inout), dimension(15) :: olp_file
       character(kind = c_char), intent(inout), dimension(15) :: olp_version
       character(kind = c_char), intent(inout), dimension(255) :: message
     end subroutine olp_info
   end interface
 
 @ %def olp_info interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: olp_set_parameter
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_set_parameter &
            (variable_name, real_part, complex_part, success) bind(C)
       import
       character(kind = c_char,len = 1), intent(in) :: variable_name
       real(kind = c_double), intent(in) :: real_part, complex_part
       integer(kind = c_int), intent(out) :: success
     end subroutine olp_set_parameter
   end interface
 
 @ %def olp_set_parameter_interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: olp_eval2
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_eval2 (label, momenta, mu, res, acc) bind(C)
       import
       integer(kind = c_int), intent(in) :: label
       real(kind = c_double), intent(in) :: mu
       real(kind = c_double), dimension(OLP_MOMENTUM_LIMIT), intent(in) :: momenta
       real(kind = c_double), dimension(OLP_RESULTS_LIMIT), intent(out) :: res
       real(kind = c_double), intent(out) :: acc
     end subroutine olp_eval2
   end interface
 
 @ %def olp_eval2 interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: olp_option
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_option (line, stat) bind(C)
       import
       character(kind = c_char, len=1), intent(in) :: line
       integer(kind = c_int), intent(out) :: stat
     end subroutine
   end interface
 
 @ %def olp_option_interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: olp_polvec
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_polvec (p, q, eps) bind(C)
       import
       real(kind = c_double), dimension(0:3), intent(in) :: p, q
       real(kind = c_double), dimension(0:7), intent(out) :: eps
     end subroutine
   end interface
 
 @ %def olp_polvec_interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: olp_finalize
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_finalize () bind(C)
       import
     end subroutine olp_finalize
   end interface
 
 @ %def olp_finalize_interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: olp_print_parameter
 <<BLHA OLP interfaces: interfaces>>=
   interface
     subroutine olp_print_parameter (filename) bind(C)
       import
       character(kind = c_char, len = 1), intent(in) :: filename
     end subroutine olp_print_parameter
   end interface
 
 @ %def olp_print_parameter_interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: blha_result_array_size
 <<BLHA OLP interfaces: procedures>>=
   pure function blha_result_array_size (n_part, amp_type) result (rsize)
     integer, intent(in) :: n_part, amp_type
     integer :: rsize
     select case (amp_type)
        case (BLHA_AMP_TREE)
           rsize = 1
        case (BLHA_AMP_LOOP)
           rsize = 4
        case (BLHA_AMP_COLOR_C)
           rsize = n_part * (n_part - 1) / 2
        case (BLHA_AMP_SPIN_C)
           rsize = 2 * n_part**2
        case default
           rsize = 0
      end select
   end function blha_result_array_size
 
 @ %def blha_result_array_size
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: create_momentum_array => prc_blha_create_momentum_array
 <<BLHA OLP interfaces: procedures>>=
   function prc_blha_create_momentum_array (object, p) result (mom)
     class(prc_blha_t), intent(in) :: object
     type(vector4_t), intent(in), dimension(:) :: p
     real(double), dimension(5*object%n_particles) :: mom
     integer :: n, i, k
 
     n = size (p)
     if (n > 10) call msg_fatal ("Number of external particles exceeds" &
          // "size of BLHA-internal momentum array")
 
     mom = zero
     k = 1
     do i = 1, n
        mom(k : k + 3) = vector4_get_components (p(i))
        mom(k + 4) = invariant_mass (p(i))
        k = k + 5
     end do
   end function prc_blha_create_momentum_array
 
 @ %def prc_blha_create_momentum_array
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: init => blha_template_init
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_template_init (template, requires_polarizations, &
          switch_off_muon_yukawas, external_top_yukawa, ew_scheme)
     class(blha_template_t), intent(inout) :: template
     logical, intent(in) :: requires_polarizations, switch_off_muon_yukawas
     real(default), intent(in) :: external_top_yukawa
     type(string_t), intent(in) :: ew_scheme
     template%compute_component = .false.
     template%include_polarizations = requires_polarizations
     template%switch_off_muon_yukawas = switch_off_muon_yukawas
     template%external_top_yukawa = external_top_yukawa
     template%ew_scheme = ew_scheme_string_to_int (ew_scheme)
   end subroutine blha_template_init
 
 @ %def blha_template_init
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: set_born => blha_template_set_born
   procedure :: set_real_trees => blha_template_set_real_trees
   procedure :: set_loop => blha_template_set_loop
   procedure :: set_subtraction => blha_template_set_subtraction
   procedure :: set_dglap => blha_template_set_dglap
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_template_set_born (template)
     class(blha_template_t), intent(inout) :: template
     template%compute_component (template%I_BORN) = .true.
   end subroutine blha_template_set_born
 
   subroutine blha_template_set_real_trees (template)
     class(blha_template_t), intent(inout) :: template
     template%compute_component (template%I_REAL) = .true.
   end subroutine blha_template_set_real_trees
 
   subroutine blha_template_set_loop (template)
     class(blha_template_t), intent(inout) :: template
     template%compute_component(template%I_LOOP) = .true.
   end subroutine blha_template_set_loop
 
   subroutine blha_template_set_subtraction (template)
     class(blha_template_t), intent(inout) :: template
     template%compute_component (template%I_SUB) = .true.
   end subroutine blha_template_set_subtraction
 
   subroutine blha_template_set_dglap (template)
     class(blha_template_t), intent(inout) :: template
     template%compute_component (template%I_DGLAP) = .true.
   end subroutine blha_template_set_dglap
 
 @ %def blha_template_set_components
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: set_internal_color_correlations &
        => blha_template_set_internal_color_correlations
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_template_set_internal_color_correlations (template)
     class(blha_template_t), intent(inout) :: template
     template%use_internal_color_correlations = .true.
   end subroutine blha_template_set_internal_color_correlations
 
 @ %def blha_template_set_internal_color_correlations
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: get_internal_color_correlations &
        => blha_template_get_internal_color_correlations
 <<BLHA OLP interfaces: procedures>>=
   pure function blha_template_get_internal_color_correlations (template) &
          result (val)
     logical :: val
     class(blha_template_t), intent(in) :: template
     val = template%use_internal_color_correlations
   end function blha_template_get_internal_color_correlations
 
 @ %def blha_template_use_internal_color_correlations
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: compute_born => blha_template_compute_born
   procedure :: compute_real_trees => blha_template_compute_real_trees
   procedure :: compute_loop => blha_template_compute_loop
   procedure :: compute_subtraction => blha_template_compute_subtraction
   procedure :: compute_dglap => blha_template_compute_dglap
 <<BLHA OLP interfaces: procedures>>=
   pure function blha_template_compute_born (template) result (val)
     class(blha_template_t), intent(in) :: template
     logical :: val
     val = template%compute_component (template%I_BORN)
   end function blha_template_compute_born
 
   pure function blha_template_compute_real_trees (template) result (val)
     class(blha_template_t), intent(in) :: template
     logical :: val
     val = template%compute_component (template%I_REAL)
   end function blha_template_compute_real_trees
 
   pure function blha_template_compute_loop (template) result (val)
     class(blha_template_t), intent(in) :: template
     logical :: val
     val = template%compute_component (template%I_LOOP)
   end function blha_template_compute_loop
 
   pure function blha_template_compute_subtraction (template) result (val)
     class(blha_template_t), intent(in) :: template
     logical :: val
     val = template%compute_component (template%I_SUB)
   end function blha_template_compute_subtraction
 
   pure function blha_template_compute_dglap (template) result (val)
     class(blha_template_t), intent(in) :: template
     logical :: val
     val = template%compute_component (template%I_DGLAP)
   end function blha_template_compute_dglap
 
 @ %def blha_template_compute
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: set_loop_method => blha_template_set_loop_method
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_template_set_loop_method (template, master)
     class(blha_template_t), intent(inout) :: template
     class(blha_master_t), intent(in) :: master
     template%loop_method = master%blha_mode(1)
   end subroutine blha_template_set_loop_method
 @ %def blha_template_set_loop_method
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: check => blha_template_check
 <<BLHA OLP interfaces: procedures>>=
   function blha_template_check (template) result (val)
     class(blha_template_t), intent(in) :: template
     logical :: val
     val = count (template%compute_component) == 1
   end function blha_template_check
 
 @ %def blha_template_check
 @
 <<BLHA OLP interfaces: blha template: TBP>>=
   procedure :: reset => blha_template_reset
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_template_reset (template)
     class(blha_template_t), intent(inout) :: template
     template%compute_component = .false.
   end subroutine blha_template_reset
 
 @ %def blha_template_reset
 @
 <<BLHA OLP interfaces: blha writer: TBP>>=
   procedure :: write => prc_blha_writer_write
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_writer_write (writer, unit)
     class(prc_blha_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     write (unit, "(1x,A)")  char (writer%get_process_string ())
   end subroutine prc_blha_writer_write
 
 @
 @ %def prc_blha_writer_write
 <<BLHA OLP interfaces: blha writer: TBP>>=
   procedure :: get_process_string => prc_blha_writer_get_process_string
 <<BLHA OLP interfaces: procedures>>=
   function prc_blha_writer_get_process_string (writer) result (s_proc)
     class(prc_blha_writer_t), intent(in) :: writer
     type(string_t) :: s_proc
     s_proc = var_str ("")
   end function prc_blha_writer_get_process_string
 
 @ %def prc_blha_writer_get_process_string
 @
 <<BLHA OLP interfaces: blha writer: TBP>>=
   procedure :: get_n_proc => prc_blha_writer_get_n_proc
 <<BLHA OLP interfaces: procedures>>=
   function prc_blha_writer_get_n_proc (writer) result (n_proc)
     class(prc_blha_writer_t), intent(in) :: writer
     integer :: n_proc
     n_proc = blha_configuration_get_n_proc (writer%blha_cfg)
   end function prc_blha_writer_get_n_proc
 
 @ %def prc_blha_writer_get_n_proc
 @
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure(blha_driver_set_GF), deferred :: &
        set_GF
 <<BLHA OLP interfaces: interfaces>>=
   abstract interface
     subroutine blha_driver_set_GF (driver, GF)
       import
       class(blha_driver_t), intent(inout) :: driver
       real(default), intent(in) :: GF
     end subroutine blha_driver_set_GF
   end interface
 
 @ %def blha_driver_set_GF
 @
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure(blha_driver_set_alpha_s), deferred :: &
        set_alpha_s
 <<BLHA OLP interfaces: interfaces>>=
   abstract interface
     subroutine blha_driver_set_alpha_s (driver, alpha_s)
        import
        class(blha_driver_t), intent(in) :: driver
        real(default), intent(in) :: alpha_s
     end subroutine blha_driver_set_alpha_s
   end interface
 
 @ %def set_alpha_s interface
 @
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure(blha_driver_set_weinberg_angle), deferred :: &
        set_weinberg_angle
 <<BLHA OLP interfaces: interfaces>>=
   abstract interface
     subroutine blha_driver_set_weinberg_angle (driver, sw2)
       import
       class(blha_driver_t), intent(inout) :: driver
       real(default), intent(in) :: sw2
     end subroutine blha_driver_set_weinberg_angle
   end interface
 
 @ %def blha_driver_set_weinberg_angle
 @
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure(blha_driver_set_alpha_qed), deferred :: set_alpha_qed
 <<BLHA OLP interfaces: interfaces>>=
   abstract interface
     subroutine blha_driver_set_alpha_qed (driver, alpha)
       import
       class(blha_driver_t), intent(inout) :: driver
       real(default), intent(in) :: alpha
     end subroutine blha_driver_set_alpha_qed
   end interface
 
 @ %def blha_driver_set_alpha_qed
 @
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure(blha_driver_print_alpha_s), deferred :: &
        print_alpha_s
 <<BLHA OLP interfaces: interfaces>>=
   abstract interface
     subroutine blha_driver_print_alpha_s (object)
       import
       class(blha_driver_t), intent(in) :: object
     end subroutine blha_driver_print_alpha_s
   end interface
 
 @ %def print_alpha_s interface
 @
 <<BLHA OLP interfaces: public>>=
   public :: parameter_error_message
 <<BLHA OLP interfaces: procedures>>=
   subroutine parameter_error_message (par, subr)
      type(string_t), intent(in) :: par, subr
      type(string_t) :: message
      message = "Setting of parameter " // par &
           // "failed in " // subr // "!"
      call msg_fatal (char (message))
   end subroutine parameter_error_message
 
 @ %def parameter_error_message
 @
 <<BLHA OLP interfaces: public>>=
   public :: ew_parameter_error_message
 <<BLHA OLP interfaces: procedures>>=
   subroutine ew_parameter_error_message (par)
      type(string_t), intent(in) :: par
      type(string_t) :: message
      message = "Setting of parameter " // par &
           // "failed. This happens because the chosen " &
           // "EWScheme in the BLHA file does not fit " &
           // "your parameter choice"
      call msg_fatal (char (message))
   end subroutine ew_parameter_error_message
 
 @ %def ew_parameter_error_message
 @
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure :: set_mass_and_width => blha_driver_set_mass_and_width
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_driver_set_mass_and_width &
          (driver, i_pdg, mass, width)
     class(blha_driver_t), intent(inout) :: driver
     integer, intent(in) :: i_pdg
     real(default), intent(in), optional :: mass
     real(default), intent(in), optional :: width
     type(string_t) :: buf
     character(kind=c_char,len=20) :: c_string
     integer :: ierr
     if (present (mass)) then
        buf = 'mass(' // str (abs(i_pdg)) // ')'
        c_string = char(buf) // c_null_char
        call driver%blha_olp_set_parameter &
             (c_string, dble(mass), 0._double, ierr)
        if (ierr == 0) then
           buf = "BLHA driver: Attempt to set mass of particle " // &
                str (abs(i_pdg)) // "failed"
           call msg_fatal (char(buf))
        end if
     end if
     if (present (width)) then
        buf = 'width(' // str (abs(i_pdg)) // ')'
        c_string = char(buf)//c_null_char
        call driver%blha_olp_set_parameter &
             (c_string, dble(width), 0._double, ierr)
        if (ierr == 0) then
           buf = "BLHA driver: Attempt to set width of particle " // &
                str (abs(i_pdg)) // "failed"
           call msg_fatal (char(buf))
        end if
     end if
   end subroutine blha_driver_set_mass_and_width
 
 @ %def blha_driver_set_mass_and_width
 @
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure(blha_driver_init_dlaccess_to_library), deferred :: &
        init_dlaccess_to_library
 <<BLHA OLP interfaces: interfaces>>=
   abstract interface
     subroutine blha_driver_init_dlaccess_to_library &
            (object, os_data, dlaccess, success)
       import
       class(blha_driver_t), intent(in) :: object
       type(os_data_t), intent(in) :: os_data
       type(dlaccess_t), intent(out) :: dlaccess
       logical, intent(out) :: success
     end subroutine blha_driver_init_dlaccess_to_library
   end interface
 
 @ %def interface blha_driver_init_dlaccess_to_library
 @
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure :: load => blha_driver_load
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_driver_load (object, os_data, success)
     class(blha_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 ("OLP_Start"))
     call c_f_procpointer (c_fptr, object%blha_olp_start)
     call check_for_error (var_str ("OLP_Start"))
 
     c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_EvalSubProcess"))
     call c_f_procpointer (c_fptr, object%blha_olp_eval)
     call check_for_error (var_str ("OLP_EvalSubProcess"))
 
     c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Info"))
     call c_f_procpointer (c_fptr, object%blha_olp_info)
     call check_for_error (var_str ("OLP_Info"))
 
     c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_SetParameter"))
     call c_f_procpointer (c_fptr, object%blha_olp_set_parameter)
     call check_for_error (var_str ("OLP_SetParameter"))
 
     c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_EvalSubProcess2"))
     call c_f_procpointer (c_fptr, object%blha_olp_eval2)
     call check_for_error (var_str ("OLP_EvalSubProcess2"))
 
     !!! The following three functions are not implemented in OpenLoops.
     !!! In another BLHA provider, they need to be implemented separately.
 
     !!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Option"))
     !!! call c_f_procpointer (c_fptr, object%blha_olp_option)
     !!! call check_for_error (var_str ("OLP_Option"))
 
     !!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Polvec"))
     !!! call c_f_procpointer (c_fptr, object%blha_olp_polvec)
     !!! call check_for_error (var_str ("OLP_Polvec"))
 
     !!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Finalize"))
     !!! call c_f_procpointer (c_fptr, object%blha_olp_finalize)
     !!! call check_for_error (var_str ("OLP_Finalize"))
 
     c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_PrintParameter"))
     call c_f_procpointer (c_fptr, object%blha_olp_print_parameter)
     call check_for_error (var_str ("OLP_PrintParameter"))
 
     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 blha_driver_load
 
 @ %def blha_driver_load
 @
 <<BLHA OLP interfaces: parameters>>=
   integer, parameter :: LEN_MAX_FLAVOR_STRING = 100
   integer, parameter :: N_MAX_FLAVORS = 100
 <<BLHA OLP interfaces: blha driver: TBP>>=
   procedure :: read_contract_file => blha_driver_read_contract_file
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_driver_read_contract_file (driver, flavors, &
          amp_type, flv_index, hel_index, label, helicities)
     class(blha_driver_t), intent(inout) :: driver
     integer, intent(in), dimension(:,:) :: flavors
     integer, intent(out), dimension(:), allocatable :: amp_type, &
          flv_index, hel_index, label
     integer, intent(out), dimension(:,:) :: helicities
     integer :: unit, filestat
     character(len=LEN_MAX_FLAVOR_STRING) :: rd_line
     logical :: read_flavor, give_warning
     integer :: label_count, i_flv
     integer :: i_hel, n_in
     integer :: i_next, n_entries
     integer, dimension(size(flavors, 1) + 2) :: i_array
     integer, dimension(size(flavors, 1) + 2) :: hel_array
     integer, parameter :: NO_NUMBER = -1000
     integer, parameter :: PROC_NOT_FOUND = -1001
     integer, parameter :: list_incr = 50
     integer :: n_found
     allocate (amp_type (N_MAX_FLAVORS), flv_index (N_MAX_FLAVORS), &
          hel_index (N_MAX_FLAVORS), label (N_MAX_FLAVORS))
     amp_type = -1; flv_index = -1; hel_index = -1; label = -1
     helicities = 0
     n_in = size (helicities, dim = 2)
     n_entries = size (flavors, 1) + 2
     unit = free_unit ()
     open (unit, file = char (driver%contract_file), status="old")
     read_flavor = .false.
     label_count = 1
     i_hel = 1
     n_found = 0
     give_warning = .false.
     do
       read (unit, "(A)", iostat = filestat) rd_line
       if (filestat == iostat_end) then
          exit
       else
          if (rd_line(1:13) == 'AmplitudeType') then
             if (i_hel > 2 * n_in) i_hel = 1
             i_next = find_next_word_index (rd_line, 13)
             if (label_count > size (amp_type)) &
                  call extend_integer_array (amp_type, list_incr)
             if (rd_line(i_next : i_next + 4) == 'Loop') then
                amp_type(label_count) = BLHA_AMP_LOOP
             else if (rd_line(i_next : i_next + 4) == 'Tree') then
                amp_type(label_count) = BLHA_AMP_TREE
             else if (rd_line(i_next : i_next + 6) == 'ccTree') then
                amp_type(label_count) = BLHA_AMP_COLOR_C
             else if (rd_line(i_next : i_next + 6) == 'scTree' .or. &
                  rd_line(i_next : i_next + 14) == 'sctree_polvect') then
                amp_type(label_count) = BLHA_AMP_SPIN_C
             else
                call msg_fatal ("AmplitudeType present but AmpType not known!")
             end if
             read_flavor = .true.
          else if (read_flavor) then
             i_array = create_flavor_string (rd_line, n_entries)
             if (driver%include_polarizations) then
                hel_array = create_helicity_string (rd_line, n_entries)
                call check_helicity_array (hel_array, n_entries, n_in)
             else
                hel_array = 0
             end if
             if (.not. all (i_array == PROC_NOT_FOUND)) then
                do i_flv = 1, size (flavors, 2)
                    if (all (i_array (1 : n_entries - 2) == flavors (:,i_flv))) then
                       if (label_count > size (label)) &
                            call extend_integer_array (label, list_incr)
                       label(label_count) = i_array (n_entries)
                       if (label_count > size (flv_index)) &
                            call extend_integer_array (flv_index, list_incr)
                       flv_index (label_count) = i_flv
                       if (label_count > size (hel_index)) &
                            call extend_integer_array (hel_index, list_incr)
                       hel_index (label_count) = i_hel
                       if (driver%include_polarizations) then
                          helicities (label(label_count), :) = hel_array (1:n_in)
                          i_hel = i_hel + 1
                       end if
                       n_found = n_found + 1
                       label_count = label_count + 1
                       exit
                    end if
                end do
                give_warning = .false.
             else
                give_warning = .true.
             end if
             read_flavor = .false.
          end if
       end if
     end do
     call crop_integer_array (amp_type, label_count-1)
     if (n_found == 0) then
        call msg_fatal ("The desired process has not been found ",  &
             [var_str ("by the OLP-Provider. Maybe the value of alpha_power "), &
             var_str ("or alphas_power does not correspond to the process. "), &
             var_str ("If you are using OpenLoops, you can set the option "), &
             var_str ("openloops_verbosity to a value larger than 1 to obtain "),  &
             var_str ("more information")])
     else if (give_warning) then
        call msg_warning ("Some processes have not been found in the OLC file.", &
             [var_str ("This is because these processes do not fit the required "), &
             var_str ("coupling alpha_power and alphas_power. Be aware that the "), &
             var_str ("results of this calculation are not necessarily an accurate "), &
             var_str ("description of the physics of interest.")])
     end if
     close(unit)
 
   contains
 
     function create_flavor_string (s, n_entries) result (i_array)
       character(len=LEN_MAX_FLAVOR_STRING), intent(in) :: s
       integer, intent(in) :: n_entries
       integer, dimension(n_entries) :: i_array
       integer :: k, current_position
       integer :: i_entry
       k = 1; current_position = 1
       do
          if (current_position > LEN_MAX_FLAVOR_STRING) &
               call msg_fatal ("Read OLC File: Current position exceeds maximum value")
          if (s(current_position:current_position) /= " ") then
             call create_flavor (s, i_entry, current_position)
             if (i_entry /= NO_NUMBER .and. i_entry /= PROC_NOT_FOUND) then
                i_array(k) = i_entry
                k = k + 1
                if (k > n_entries) then
                   return
                else
                   call increment_current_position (s, current_position)
                end if
             else if (i_entry == PROC_NOT_FOUND) then
                i_array = PROC_NOT_FOUND
                return
             else
                call increment_current_position (s, current_position)
             end if
          else
             call increment_current_position (s, current_position)
          end if
       end do
     end function create_flavor_string
 
     function create_helicity_string (s, n_entries) result (hel_array)
       character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s
       integer, intent(in) :: n_entries
       integer, dimension(n_entries) :: hel_array
       integer :: k, current_position
       integer :: hel
       k = 1; current_position = 1
       do
          if (current_position > LEN_MAX_FLAVOR_STRING) &
               call msg_fatal ("Read OLC File: Current position exceeds maximum value")
          if (s(current_position:current_position) /= " ") then
             call create_helicity (s, hel, current_position)
             if (hel >= -1 .and. hel <= 1) then
                hel_array(k) = hel
                k = k + 1
                if (k > n_entries) then
                   return
                else
                   call increment_current_position (s, current_position)
                end if
             else
                call increment_current_position (s, current_position)
             end if
          else
             call increment_current_position (s, current_position)
          end if
       end do
     end function create_helicity_string
 
     subroutine increment_current_position (s, current_position)
       character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s
       integer, intent(inout) :: current_position
       current_position = find_next_word_index (s, current_position)
     end subroutine increment_current_position
 
     subroutine get_next_buffer (s, current_position, buf, last_buffer_index)
       character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s
       integer, intent(inout) :: current_position
       character(len = 10), intent(out) :: buf
       integer, intent(out) :: last_buffer_index
       integer :: i
       i = 1; buf = ""
       do
          if (s(current_position:current_position) /= " ") then
             buf(i:i) = s(current_position:current_position)
             i = i + 1; current_position = current_position + 1
          else
             exit
          end if
       end do
       last_buffer_index = i
     end subroutine get_next_buffer
 
     function is_particle_buffer (buf, i) result (valid)
       logical :: valid
       character(len = 10), intent(in) :: buf
       integer, intent(in) :: i
       valid = (buf(1 : i - 1) /= "->" .and. buf(1 : i - 1) /= "|" &
            .and. buf(1 : i - 1) /= "Process")
     end function is_particle_buffer
 
     subroutine create_flavor (s, i_particle, current_position)
       character(len=LEN_MAX_FLAVOR_STRING), intent(in) :: s
       integer, intent(out) :: i_particle
       integer, intent(inout) :: current_position
       character(len=10) :: buf
       integer :: i, last_buffer_index
       call get_next_buffer (s, current_position, buf, last_buffer_index)
       i = last_buffer_index
       if (is_particle_buffer (buf, i)) then
          call strip_helicity (buf, i)
          i_particle = read_ival (var_str (buf(1 : i - 1)))
       else if (buf(1 : i - 1) == "Process") then
          i_particle = PROC_NOT_FOUND
       else
          i_particle = NO_NUMBER
       end if
     end subroutine create_flavor
 
     subroutine create_helicity (s, helicity, current_position)
       character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s
       integer, intent(out) :: helicity
       integer, intent(inout) :: current_position
       character(len = 10) :: buf
       integer :: i, last_buffer_index
       logical :: success
       call get_next_buffer (s, current_position, buf, last_buffer_index)
       i = last_buffer_index
       if (is_particle_buffer (buf, i)) then
          call strip_flavor (buf, i, helicity, success)
       else
          helicity = 0
       end if
     end subroutine create_helicity
 
     subroutine strip_helicity (buf, i)
       character(len = 10), intent(in) :: buf
       integer, intent(inout) :: i
       integer :: i_last
       i_last = i - 1
       if (i_last < 4) return
       if (buf(i_last - 2 : i_last) == "(1)") then
          i = i - 3
       else if (buf(i_last - 3 : i_last) == "(-1)") then
          i = i - 4
       end if
     end subroutine strip_helicity
 
     subroutine strip_flavor (buf, i, helicity, success)
       character(len = 10), intent(in) :: buf
       integer, intent(in) :: i
       integer, intent(out) :: helicity
       logical, intent(out) :: success
       integer :: i_last
       i_last = i - 1
       helicity = 0
       if (i_last < 4) return
       if (buf(i_last - 2 : i_last) == "(1)") then
          helicity = 1
          success = .true.
       else if (buf(i_last - 3 : i_last) == "(-1)") then
          helicity = -1
          success = .true.
       else
          success = .false.
       end if
     end subroutine strip_flavor
 
     function find_next_word_index (word, i_start) result (i_next)
       character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: word
       integer, intent(in) :: i_start
       integer :: i_next
       i_next = i_start + 1
       do
          if (word(i_next : i_next) /= " ") then
             exit
          else
             i_next = i_next + 1
          end if
          if (i_next > LEN_MAX_FLAVOR_STRING) &
               call msg_fatal ("Find next word: line limit exceeded")
       end do
     end function find_next_word_index
 
     subroutine check_helicity_array (hel_array, n_entries, n_in)
       integer, intent(in), dimension(:) :: hel_array
       integer, intent(in) :: n_entries, n_in
       integer :: n_particles, i
       logical :: valid
       n_particles = n_entries - 2
       !!! only allow polarisations for incoming fermions for now
       valid = all (hel_array (n_in + 1 : n_particles) == 0)
       do i = 1, n_in
          valid = valid .and. (hel_array(i) == 1 .or. hel_array(i) == -1)
       end do
       if (.not. valid) &
            call msg_fatal ("Invalid helicities encountered!")
     end subroutine check_helicity_array
 
   end subroutine blha_driver_read_contract_file
 
 @ %def blha_driver_read_contract_file
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: set_alpha_qed => prc_blha_set_alpha_qed
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_set_alpha_qed (object, model)
     class(prc_blha_t), intent(inout) :: object
     type(model_data_t), intent(in), target :: model
     real(default) :: alpha
 
     alpha = one / model%get_real (var_str ('alpha_em_i'))
 
     select type (driver => object%driver)
     class is (blha_driver_t)
        call driver%set_alpha_qed (alpha)
     end select
   end subroutine prc_blha_set_alpha_qed
 
 @ %def prc_blha_set_alpha_qed
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: set_GF => prc_blha_set_GF
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_set_GF (object, model)
     class(prc_blha_t), intent(inout) :: object
     type(model_data_t), intent(in), target :: model
     real(default) :: GF
 
     GF = model%get_real (var_str ('GF'))
     select type (driver => object%driver)
     class is (blha_driver_t)
        call driver%set_GF (GF)
     end select
   end subroutine prc_blha_set_GF
 
 @ %def prc_blha_set_GF
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: set_weinberg_angle => prc_blha_set_weinberg_angle
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_set_weinberg_angle (object, model)
     class(prc_blha_t), intent(inout) :: object
     type(model_data_t), intent(in), target :: model
     real(default) :: sw2
 
     sw2 = model%get_real (var_str ('sw2'))
     select type (driver => object%driver)
     class is (blha_driver_t)
       call driver%set_weinberg_angle (sw2)
     end select
   end subroutine prc_blha_set_weinberg_angle
 
 @ %def prc_blha_set_weinberg_angle
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: set_electroweak_parameters => &
        prc_blha_set_electroweak_parameters
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_set_electroweak_parameters (object, model)
      class(prc_blha_t), intent(inout) :: object
      type(model_data_t), intent(in), target :: model
      if (count (object%ew_parameter_mask) == 0) then
         call msg_fatal ("Cannot decide EW parameter setting: No scheme set!")
      else if (count (object%ew_parameter_mask) > 1) then
         call msg_fatal ("Cannot decide EW parameter setting: More than one scheme set!")
      end if
      if (object%ew_parameter_mask (I_ALPHA_INTERNAL)) call object%set_alpha_qed (model)
      if (object%ew_parameter_mask (I_GF)) call object%set_GF (model)
      if (object%ew_parameter_mask (I_SW2)) call object%set_weinberg_angle (model)
   end subroutine prc_blha_set_electroweak_parameters
 
 @ %def prc_blha_set_electrweak_parameters
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: read_contract_file => prc_blha_read_contract_file
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_read_contract_file (object, flavors)
     class(prc_blha_t), intent(inout) :: object
     integer, intent(in), dimension(:,:) :: flavors
     integer, dimension(:), allocatable :: amp_type, flv_index, hel_index, label
     integer, dimension(:,:), allocatable :: helicities
     integer :: i_proc, i_hel
     allocate (helicities (N_MAX_FLAVORS, object%data%n_in))
     select type (driver => object%driver)
     class is (blha_driver_t)
        call driver%read_contract_file (flavors, amp_type, flv_index, &
             hel_index, label, helicities)
     end select
     object%n_proc = count (amp_type >= 0)
     do i_proc = 1, object%n_proc
        if (amp_type (i_proc) < 0) exit
        if (hel_index(i_proc) < 0 .and. object%includes_polarization ()) &
             call msg_bug ("Object includes polarization, but helicity index is undefined.")
        i_hel = hel_index (i_proc)
        select case (amp_type (i_proc))
        case (BLHA_AMP_TREE)
           if (allocated (object%i_tree)) then
              object%i_tree(flv_index(i_proc), i_hel) = label(i_proc)
           else
              call msg_fatal ("Tree matrix element present, &
                   &but neither Born nor real indices are allocated!")
           end if
        case (BLHA_AMP_COLOR_C)
           if (allocated (object%i_color_c)) then
              object%i_color_c(flv_index(i_proc), i_hel) = label(i_proc)
           else
              call msg_fatal ("Color-correlated matrix element present, &
                   &but cc-indices are not allocated!")
           end if
        case (BLHA_AMP_SPIN_C)
           if (allocated (object%i_spin_c)) then
              object%i_spin_c(flv_index(i_proc), i_hel) = label(i_proc)
           else
              call msg_fatal ("Spin-correlated matrix element present, &
                   &but sc-indices are not allocated!")
           end if
        case (BLHA_AMP_LOOP)
           if (allocated (object%i_virt)) then
              object%i_virt(flv_index(i_proc), i_hel) = label(i_proc)
           else
              call msg_fatal ("Loop matrix element present, &
                   &but virt-indices are not allocated!")
           end if
        case default
           call msg_fatal ("Undefined amplitude type")
        end select
        if (allocated (object%i_hel)) &
             object%i_hel (i_proc, :) = helicities (label(i_proc), :)
     end do
   end subroutine prc_blha_read_contract_file
 
 @ %def prc_blha_read_contract_file
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: print_parameter_file => prc_blha_print_parameter_file
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_print_parameter_file (object, i_component)
     class(prc_blha_t), intent(in) :: object
     integer, intent(in) :: i_component
     type(string_t) :: filename
 
     select type (def => object%def)
     class is (blha_def_t)
        filename = def%basename // '_' // str (i_component) // '.olp_parameters'
     end select
     select type (driver => object%driver)
     class is (blha_driver_t)
        call driver%blha_olp_print_parameter (char(filename)//c_null_char)
     end select
   end subroutine prc_blha_print_parameter_file
 
 @ %def prc_blha_print_parameter_file
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: compute_amplitude => prc_blha_compute_amplitude
 <<BLHA OLP interfaces: procedures>>=
   function prc_blha_compute_amplitude &
          (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, &
          core_state)  result (amp)
     class(prc_blha_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 (blha_state_t)
       core_state%alpha_qcd = object%qcd%alpha%get (ren_scale)
     end select
     amp = zero
   end function prc_blha_compute_amplitude
 
 @
 @ %def prc_blha_compute_amplitude
 <<BLHA OLP interfaces: prc blha: TBP>>=
    procedure :: init_blha => prc_blha_init_blha
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_init_blha (object, blha_template, n_in, &
          n_particles, n_flv, n_hel)
     class(prc_blha_t), intent(inout) :: object
     type(blha_template_t), intent(in) :: blha_template
     integer, intent(in) :: n_in, n_particles, n_flv, n_hel
     object%n_particles = n_particles
     object%n_flv = n_flv
     object%n_hel = n_hel
     if (blha_template%compute_loop ()) then
        if (blha_template%include_polarizations) then
           allocate (object%i_virt (n_flv, n_hel), &
                object%i_color_c (n_flv, n_hel))
           if (blha_template%use_internal_color_correlations) then
              allocate (object%i_hel (n_flv * n_in * n_hel * 2, n_in))
           else
              allocate (object%i_hel (n_flv * n_in * n_hel, n_in))
           end if
        else
           allocate (object%i_virt (n_flv, 1), object%i_color_c (n_flv, 1))
        end if
        object%i_virt = -1
        object%i_color_c = -1
     else if (blha_template%compute_subtraction ()) then
        if (blha_template%include_polarizations) then
           allocate (object%i_tree (n_flv, n_hel), &
                object%i_color_c (n_flv, n_hel), &
                object%i_spin_c (n_flv, n_hel), &
                object%i_hel (3 * (n_flv * n_hel * n_in), n_in))
           object%i_hel = 0
        else
           allocate (object%i_tree (n_flv, 1), object%i_color_c (n_flv, 1) , &
                object%i_spin_c (n_flv, 1))
        end if
        object%i_tree = -1
        object%i_color_c = -1
        object%i_spin_c = -1
     else if (blha_template%compute_real_trees () .or. blha_template%compute_born () &
          .or. blha_template%compute_dglap ()) then
        if (blha_template%include_polarizations) then
           allocate (object%i_tree (n_flv, n_hel))
           allocate (object%i_hel (n_flv * n_hel * n_in, n_in))
           object%i_hel = 0
        else
           allocate (object%i_tree (n_flv, 1))
        end if
        object%i_tree = -1
     end if
 
     call object%init_ew_parameters (blha_template%ew_scheme)
 
     select type (driver => object%driver)
     class is (blha_driver_t)
        driver%include_polarizations = blha_template%include_polarizations
        driver%switch_off_muon_yukawas = blha_template%switch_off_muon_yukawas
        driver%external_top_yukawa = blha_template%external_top_yukawa
     end select
   end subroutine prc_blha_init_blha
 
 @ %def prc_blha_init_blha
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: set_mass_and_width => prc_blha_set_mass_and_width
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_set_mass_and_width (object, i_pdg, mass, width)
     class(prc_blha_t), intent(inout) :: object
     integer, intent(in) :: i_pdg
     real(default), intent(in) :: mass, width
     select type (driver => object%driver)
     class is (blha_driver_t)
        call driver%set_mass_and_width (i_pdg, mass, width)
     end select
   end subroutine prc_blha_set_mass_and_width
 
 @ %def prc_blha_set_mass_and_width
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: set_particle_properties => prc_blha_set_particle_properties
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_set_particle_properties (object, model)
     class(prc_blha_t), intent(inout) :: object
     class(model_data_t), intent(in), target :: model
     integer :: i, i_pdg
     type(flavor_t) :: flv
     real(default) :: mass, width
     integer :: ierr
     real(default) :: top_yukawa
     do i = 1, OLP_N_MASSIVE_PARTICLES
        i_pdg = OLP_MASSIVE_PARTICLES(i)
        if (i_pdg < 0) cycle
        call flv%init (i_pdg, model)
        mass = flv%get_mass (); width = flv%get_width ()
        select type (driver => object%driver)
        class is (blha_driver_t)
           call driver%set_mass_and_width (i_pdg, mass = mass, width = width)
           if (i_pdg == 5) call driver%blha_olp_set_parameter &
                ('yuk(5)'//c_null_char, dble(mass), 0._double, ierr)
           if (i_pdg == 6) then
              if (driver%external_top_yukawa > 0._default) then
                 top_yukawa = driver%external_top_yukawa
              else
                 top_yukawa = mass
              end if
              call driver%blha_olp_set_parameter &
                   ('yuk(6)'//c_null_char, dble(top_yukawa), 0._double, ierr)
           end if
           if (driver%switch_off_muon_yukawas) then
              if (i_pdg == 13) call driver%blha_olp_set_parameter &
                   ('yuk(13)' //c_null_char, 0._double, 0._double, ierr)
           end if
        end select
     end do
   end subroutine prc_blha_set_particle_properties
 
 @ %def prc_blha_set_particle_properties
 @ This mask adapts which electroweak parameters are supposed to set according to
 the chosen BLHA EWScheme. This is only implemented for the default OLP method so far.
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: init_ew_parameters => prc_blha_init_ew_parameters
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_init_ew_parameters (object, ew_scheme)
     class(prc_blha_t), intent(inout) :: object
     integer, intent(in) :: ew_scheme
     object%ew_parameter_mask = .false.
     select case (ew_scheme)
     case (BLHA_EW_0)
        object%ew_parameter_mask (I_ALPHA_0) = .true.
     case (BLHA_EW_GF)
        object%ew_parameter_mask (I_GF) = .true.
     case (BLHA_EW_MZ)
        object%ew_parameter_mask (I_ALPHA_MZ) = .true.
     case (BLHA_EW_INTERNAL)
        object%ew_parameter_mask (I_ALPHA_INTERNAL) = .true.
     end select
   end subroutine prc_blha_init_ew_parameters
 
 @ %def prc_blha_init_ew_parameters
 @ Computes a virtual matrix element from an interface to an
 external one-loop provider. The output of [[blha_olp_eval2]]
 is an array of [[dimension(4)]], corresponding to the
 $\epsilon^2$-, $\epsilon^1$- and $\epsilon^0$-poles of the
 virtual matrix element at position [[r(1:3)]] and the Born
 matrix element at position [[r(4)]]. The matrix element is
 rejected if its accuracy is larger than the maximal allowed
 accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the
 amplitudes, which we have to undo if polarized matrix elements
 are requested (GoSam does not support polarized matrix elements).
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: compute_sqme_virt => prc_blha_compute_sqme_virt
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_compute_sqme_virt (object, &
          i_flv, i_hel, p, ren_scale, es_scale, loop_method, sqme, bad_point)
     class(prc_blha_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
     logical, intent(out) :: bad_point
     real(double), dimension(5 * object%n_particles) :: mom
     real(double), dimension(:), allocatable :: r
     real(double) :: mu_dble, es_dble
     real(double) :: acc_dble
     real(default) :: acc
     real(default) :: alpha_s
     integer :: ierr
     if (object%i_virt(i_flv, i_hel) >= 0) then
        allocate (r (blha_result_array_size (object%n_particles, BLHA_AMP_LOOP)))
        if (debug_on) call msg_debug2 (D_VIRTUAL, "prc_blha_compute_sqme_virt")
        if (debug_on) call msg_debug2 (D_VIRTUAL, "i_flv", i_flv)
        if (debug_on) call msg_debug2 (D_VIRTUAL, "object%i_virt(i_flv, i_hel)", object%i_virt(i_flv, i_hel))
        if (debug2_active (D_VIRTUAL)) then
            call msg_debug2 (D_VIRTUAL, "use momenta: ")
            call vector4_write_set (p, show_mass = .true., &
                 check_conservation = .true.)
        end if
        mom = object%create_momentum_array (p)
        if (vanishes (ren_scale)) &
             call msg_fatal ("prc_blha_compute_sqme_virt: ren_scale vanishes")
        mu_dble = dble (ren_scale)
        es_dble = dble (es_scale)
        alpha_s = object%qcd%alpha%get (ren_scale)
        select type (driver => object%driver)
        class is (blha_driver_t)
           if (loop_method == BLHA_MODE_OPENLOOPS) then
              call driver%blha_olp_set_parameter ('mureg'//c_null_char, es_dble, 0._double, ierr)
              if (ierr == 0) call parameter_error_message (var_str ('mureg'), &
                   var_str ('prc_blha_compute_sqme_virt'))
           end if
           call driver%set_alpha_s (alpha_s)
           call driver%blha_olp_eval2 (object%i_virt(i_flv, i_hel), mom, mu_dble, r, acc_dble)
        end select
        acc = acc_dble
        sqme = r(1:4)
        bad_point = acc > object%maximum_accuracy
        if (object%includes_polarization ()) sqme = object%n_hel * sqme
     else
        sqme = zero
     end if
   end subroutine prc_blha_compute_sqme_virt
 
 @ %def prc_blha_compute_sqme_virt
 @ Computes a tree-level matrix element from an interface to an
 external one-loop provider. The matrix element is
 rejected if its accuracy is larger than the maximal allowed
 accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the
 amplitudes, which we have to undo if polarized matrix elements
 are requested (GoSam does not support polarized matrix elements).
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: compute_sqme => prc_blha_compute_sqme
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_compute_sqme (object, i_flv, i_hel, p, &
          ren_scale, sqme, bad_point)
     class(prc_blha_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
     real(double), dimension(5*object%n_particles) :: mom
     real(double), dimension(OLP_RESULTS_LIMIT) :: r
     real(double) :: mu_dble, acc_dble
     real(default) :: acc, alpha_s
     if (object%i_tree(i_flv, i_hel) >= 0) then
        if (debug_on) call msg_debug2 (D_REAL, "prc_blha_compute_sqme")
        if (debug_on) call msg_debug2 (D_REAL, "i_flv", i_flv)
        if (debug2_active (D_REAL)) then
            call msg_debug2 (D_REAL, "use momenta: ")
            call vector4_write_set (p, show_mass = .true., &
                 check_conservation = .true.)
        end if
        mom = object%create_momentum_array (p)
        if (vanishes (ren_scale)) &
             call msg_fatal ("prc_blha_compute_sqme: ren_scale vanishes")
        mu_dble = dble(ren_scale)
        alpha_s = object%qcd%alpha%get (ren_scale)
        select type (driver => object%driver)
        class is (blha_driver_t)
           call driver%set_alpha_s (alpha_s)
           call driver%blha_olp_eval2 (object%i_tree(i_flv, i_hel), mom, &
                mu_dble, r, acc_dble)
           sqme = r(object%sqme_tree_pos)
        end select
        acc = acc_dble
        bad_point = acc > object%maximum_accuracy
        if (object%includes_polarization ()) sqme = object%n_hel * sqme
     else
        sqme = zero
     end if
   end subroutine prc_blha_compute_sqme
 
 @ %def prc_blha_compute_sqme
 @
 <<BLHA OLP interfaces: public>>=
   public :: blha_color_c_fill_diag
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_color_c_fill_diag (sqme_born, flavors, sqme_color_c)
      real(default), intent(in) :: sqme_born
      integer, intent(in), dimension(:) :: flavors
      real(default), intent(inout), dimension(:,:) :: sqme_color_c
      integer :: i
      do i = 1, size (flavors)
         if (is_quark (flavors(i))) then
            sqme_color_c (i, i) = -cf * sqme_born
         else if (is_gluon (flavors(i))) then
            sqme_color_c (i, i) = -ca * sqme_born
         else
            sqme_color_c (i, i) = zero
         end if
      end do
   end subroutine blha_color_c_fill_diag
 
 @ %def blha_color_c_fill_diag
 <<BLHA OLP interfaces: public>>=
   public :: blha_color_c_fill_offdiag
 <<BLHA OLP interfaces: procedures>>=
   subroutine blha_color_c_fill_offdiag (n, r, sqme_color_c, offset, n_flv)
     integer, intent(in) :: n
     real(default), intent(in), dimension(:) :: r
     real(default), intent(inout), dimension(:,:) :: sqme_color_c
     integer, intent(in), optional :: offset, n_flv
     integer :: i, j, pos, incr
     if (present (offset)) then
        incr = offset
     else
        incr = 0
     end if
     pos = 0
     do j = 1, n
        do i = 1, j
           if (i /= j) then
              pos = (j - 1) * (j - 2) / 2 + i
              if (present (n_flv))  incr = incr + n_flv - 1
              if (present (offset))  pos = pos + incr
              sqme_color_c (i, j) = -r (pos)
              sqme_color_c (j, i) = sqme_color_c (i, j)
           end if
        end do
     end do
   end subroutine blha_color_c_fill_offdiag
 
 @ %def blha_color_c_fill_offdiag
 @ Computes a color-correlated matrix element from an interface to an
 external one-loop provider. The output of [[blha_olp_eval2]] is
 an array of [[dimension(n * (n - 1) / 2)]]. The matrix element is
 rejected if its accuracy is larger than the maximal allowed
 accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the
 amplitudes, which we have to undo if polarized matrix elements
 are requested (GoSam does not support polarized matrix elements).
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: compute_sqme_color_c_raw => prc_blha_compute_sqme_color_c_raw
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_compute_sqme_color_c_raw &
          (object, i_flv, i_hel, p, ren_scale, rr, bad_point)
     class(prc_blha_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), dimension(:) :: rr
     logical, intent(out) :: bad_point
     real(double), dimension(5 * object%n_particles) :: mom
     real(double), dimension(size(rr)) :: r
     real(default) :: alpha_s, acc
     real(double) :: mu_dble, acc_dble
     if (debug2_active (D_REAL)) then
        call msg_debug2 (D_REAL, "use momenta: ")
        call vector4_write_set (p, show_mass = .true., &
             check_conservation = .true.)
     end if
     if (object%i_color_c(i_flv, i_hel) >= 0) then
        mom = object%create_momentum_array (p)
        if (vanishes (ren_scale)) &
             call msg_fatal ("prc_blha_compute_sqme_color_c: ren_scale vanishes")
        mu_dble = dble(ren_scale)
        alpha_s = object%qcd%alpha%get (ren_scale)
 
        select type (driver => object%driver)
        class is (blha_driver_t)
           call driver%set_alpha_s (alpha_s)
           call driver%blha_olp_eval2 (object%i_color_c(i_flv, i_hel), &
                mom, mu_dble, r, acc_dble)
        end select
        rr = r
        acc = acc_dble
        bad_point = acc > object%maximum_accuracy
        if (object%includes_polarization ())  rr = object%n_hel * rr
     else
        rr = zero
     end if
   end subroutine prc_blha_compute_sqme_color_c_raw
 
 @ %def prc_blha_compute_sqme_color_c_raw
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: compute_sqme_color_c => prc_blha_compute_sqme_color_c
 <<BLHA OLP interfaces: procedures>>=
   subroutine prc_blha_compute_sqme_color_c &
          (object, i_flv, i_hel, p, ren_scale, born_color_c, bad_point, born_out)
     class(prc_blha_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
     real(default), intent(out), optional :: born_out
     logical, intent(out) :: bad_point
     real(default), dimension(:), allocatable :: r
     logical :: bad_point2
     real(default) :: born
     integer, dimension(:), allocatable :: flavors
     if (debug2_active (D_REAL)) then
        call msg_debug2 (D_REAL, "use momenta: ")
        call vector4_write_set (p, show_mass = .true., &
             check_conservation = .true.)
     end if
     allocate (r (blha_result_array_size &
          (size(born_color_c, dim=1), BLHA_AMP_COLOR_C)))
     call object%compute_sqme_color_c_raw (i_flv, i_hel, p, ren_scale, r, bad_point)
 
     select type (driver => object%driver)
     class is (blha_driver_t)
        if (allocated (object%i_tree)) then
           call object%compute_sqme (i_flv, i_hel, p, ren_scale, born, bad_point2)
        else
           born = zero
        end if
        if (present (born_out)) born_out = born
     end select
     call blha_color_c_fill_offdiag (object%n_particles, r, born_color_c)
     flavors = object%get_flv_state (i_flv)
     call blha_color_c_fill_diag (born, flavors, born_color_c)
 
     bad_point = bad_point .or. bad_point2
   end subroutine prc_blha_compute_sqme_color_c
 
 @ %def prc_blha_compute_sqme_color_c
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   generic :: get_beam_helicities => get_beam_helicities_single
   generic :: get_beam_helicities => get_beam_helicities_array
   procedure :: get_beam_helicities_single => prc_blha_get_beam_helicities_single
   procedure :: get_beam_helicities_array => prc_blha_get_beam_helicities_array
 <<BLHA OLP interfaces: procedures>>=
   function prc_blha_get_beam_helicities_single (object, i, invert_second) result (hel)
     integer, dimension(:), allocatable :: hel
     class(prc_blha_t), intent(in) :: object
     logical, intent(in), optional :: invert_second
     integer, intent(in) :: i
     logical :: inv
     inv = .false.; if (present (invert_second)) inv = invert_second
     allocate (hel (object%data%n_in))
     hel = object%i_hel (i, :)
     if (inv .and. object%data%n_in == 2) hel(2) = -hel(2)
   end function prc_blha_get_beam_helicities_single
 
 @ %def prc_blha_get_beam_helicities_single
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure :: includes_polarization => prc_blha_includes_polarization
 <<BLHA OLP interfaces: procedures>>=
   function prc_blha_includes_polarization (object) result (polarized)
     logical :: polarized
     class(prc_blha_t), intent(in) :: object
     select type (driver => object%driver)
     class is (blha_driver_t)
        polarized = driver%include_polarizations
     end select
   end function prc_blha_includes_polarization
 
 @ %def prc_blha_includes_polarization
 @
 <<BLHA OLP interfaces: procedures>>=
   function prc_blha_get_beam_helicities_array (object, invert_second) result (hel)
     integer, dimension(:,:), allocatable :: hel
     class(prc_blha_t), intent(in) :: object
     logical, intent(in), optional :: invert_second
     integer :: i
     allocate (hel (object%n_proc, object%data%n_in))
     do i = 1, object%n_proc
        hel(i,:) = object%get_beam_helicities (i, invert_second)
     end do
   end function prc_blha_get_beam_helicities_array
 
 @ %def prc_blha_get_beam_helicities_array
+@ 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. Overrides [[prc_core_set_equivalent_flv_hel_indices]].
+<<BLHA OLP interfaces: prc blha: TBP>>=
+  procedure :: set_equivalent_flv_hel_indices => prc_blha_set_equivalent_flv_hel_indices
+<<BLHA OLP interfaces: procedures>>=
+  subroutine prc_blha_set_equivalent_flv_hel_indices (object)
+    class(prc_blha_t), intent(inout) :: object
+    integer :: n_flv, n_hel
+    integer :: i_flv1, i_flv2, i_hel1, i_hel2
+    integer, dimension(:,:), allocatable :: amp_id
+    if (allocated (object%i_virt)) then
+       amp_id = object%i_virt
+    else
+       amp_id = object%i_tree
+    end if
+    n_flv = size (amp_id, dim=1)
+    n_hel = size (amp_id, dim=2)
+    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.")
+    do i_flv1 = 1, n_flv
+       do i_hel1 = 1, n_hel
+          FLV_LOOP: do i_flv2 = 1, i_flv1
+             do i_hel2 = 1, i_hel1
+                if (amp_id(i_flv2, i_hel2) == &
+                     amp_id(i_flv1, i_hel1)) then
+                   object%data%eqv_flv_index(i_flv1) = i_flv2
+                   object%data%eqv_hel_index(i_hel1) = i_hel2
+                   exit FLV_LOOP
+                end if
+             end do
+          end do FLV_LOOP
+       end do
+    end do
+  end subroutine prc_blha_set_equivalent_flv_hel_indices
+
+@ %def prc_blha_set_equivalent_flv_hel_indices
 @
 <<BLHA OLP interfaces: prc blha: TBP>>=
   procedure(prc_blha_init_driver), deferred :: &
        init_driver
 <<BLHA OLP interfaces: interfaces>>=
   abstract interface
     subroutine prc_blha_init_driver (object, os_data)
       import
       class(prc_blha_t), intent(inout) :: object
       type(os_data_t), intent(in) :: os_data
     end subroutine prc_blha_init_driver
   end interface
 
 @ %def prc_blha_init_driver interface
 @ In general, the BLHA consits of a virtual matrix element and $n_{\rm{sub}}$
 subtraction terms. The subtractions terms can be pure Born matrix elements
 (to be used in collinear subtraction or in internal color-correlation),
 color-correlated matrix elements or spin-correlated matrix elements.
 The numbers should be ordered in such a way that $\mathcal{V}_{\rm{fin}}$
 is first, followed by the pure Born, the color-correlated and the spin-correlated
 matrix elements. This repeats $n_{\rm{flv}}$ times. Let $\nu_i$ be the position
 of the $ith$ virtual matrix element. The next $\mathcal{V}_{\rm{fin}}$ is
 at position $\nu_i = \nu_{i - 1} + n_{\rm{sub}} + 1$. Obviously, $\nu_1 = 1$.
 This allows us to determine the virtual matrix element positions using the
 recursive function implemented below.
 <<BLHA OLP interfaces: public>>=
   public :: blha_loop_positions
 <<BLHA OLP interfaces: procedures>>=
   recursive function blha_loop_positions (i_flv, n_sub) result (index)
     integer :: index
     integer, intent(in) :: i_flv, n_sub
     index = 0
     if (i_flv == 1) then
        index = 1
     else
        index = blha_loop_positions (i_flv - 1, n_sub) + n_sub + 1
     end if
   end function blha_loop_positions
 
 @ %def blha_loop_positions
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 The module is split into a configuration interface which manages configuration
 and handles the request and contract files, a module which interfaces the OLP
 matrix elements and a driver.
 
 <<[[blha_config.f90]]>>=
 <<File header>>
 
 module blha_config
 
   use kinds
 <<Use strings>>
   use io_units
   use constants
   use string_utils
   use variables, only: var_list_t
   use diagnostics
   use md5
   use model_data
   use flavors
   use quantum_numbers
   use pdg_arrays
   use sorting
   use lexers
   use parser
   use syntax_rules
   use ifiles
 
   use beam_structures, only: beam_structure_t
 
 <<Use mpi f08>>
 <<Standard module head>>
 
 <<BLHA config: public>>
 
 <<BLHA config: parameters>>
 
 <<BLHA config: types>>
 
 <<BLHA config: variables>>
 
 <<BLHA config: interfaces>>
 
 contains
 
 <<BLHA config: procedures>>
 
 end module blha_config
 
 @ %def blha_config
 @
 \section{Configuration}
 
 Parameters to enumerate the different options in the order.
 <<BLHA config: parameters>>=
   integer, public, parameter :: &
        BLHA_CT_QCD = 1, BLHA_CT_EW = 2, BLHA_CT_OTHER = 3
   integer, public, parameter :: &
        BLHA_IRREG_CDR = 1, BLHA_IRREG_DRED = 2, BLHA_IRREG_THV = 3, &
        BLHA_IRREG_MREG = 4, BLHA_IRREG_OTHER = 5
   integer, public, parameter :: &
        BLHA_MPS_ONSHELL = 1, BLHA_MPS_OTHER = 2
   integer, public, parameter :: &
        BLHA_MODE_GOSAM = 1, BLHA_MODE_FEYNARTS = 2, BLHA_MODE_GENERIC = 3, &
        BLHA_MODE_OPENLOOPS = 4
   integer, public, parameter :: &
        BLHA_VERSION_1 = 1, BLHA_VERSION_2 = 2
   integer, public, parameter :: &
        BLHA_AMP_LOOP = 1, BLHA_AMP_COLOR_C = 2, BLHA_AMP_SPIN_C = 3, &
        BLHA_AMP_TREE = 4, BLHA_AMP_LOOPINDUCED = 5
   integer, public, parameter :: &
        BLHA_EW_INTERNAL = 0, &
        BLHA_EW_GF = 1, BLHA_EW_MZ = 2, BLHA_EW_MSBAR = 3, &
        BLHA_EW_0 = 4, BLHA_EW_RUN = 5
   integer, public, parameter :: &
        BLHA_WIDTH_COMPLEX = 1, BLHA_WIDTH_FIXED = 2, &
        BLHA_WIDTH_RUNNING = 3, BLHA_WIDTH_POLE = 4, &
        BLHA_WIDTH_DEFAULT = 5
 
 @ %def blha_ct_qcd blha_ct_ew blha_ct_other
 @ %def blha_irreg_cdr blha_irreg_dred blha_irreg_thv blha_irreg_mreg blha_irreg_other
 @ %def blha_mps_onshell blha_mps_other
 @ %def blha_mode_gosam blha_mode_feynarts blha_mode_generic
 @ %def blha version blha_amp blha_ew blha_width
 @
 Those are the default pdg codes for massive particles in BLHA programs
 <<BLHA config: parameters>>=
   integer, parameter, public :: OLP_N_MASSIVE_PARTICLES = 12
   integer, dimension(OLP_N_MASSIVE_PARTICLES), public :: &
        OLP_MASSIVE_PARTICLES = [5, -5, 6, -6, 13, -13, 15, -15, 23, 24, -24, 25]
   integer, parameter :: OLP_HEL_UNPOLARIZED = 0
 
 @ %def OLP_MASSIVE_PARTICLES
 @ The user might provide an extra command string for OpenLoops to
 apply special libraries instead of the default ones, such as
 signal-only amplitudes for off-shell top production. We check in this
 subroutine that the provided string is valid and print out the
 possible options to ease the user's memory.
 <<BLHA config: parameters>>=
   integer, parameter :: N_KNOWN_SPECIAL_OL_METHODS = 3
 <<BLHA config: procedures>>=
   subroutine check_extra_cmd (extra_cmd)
     type(string_t), intent(in) :: extra_cmd
     type(string_t), dimension(N_KNOWN_SPECIAL_OL_METHODS) :: known_methods
     integer :: i
     logical :: found
     known_methods(1) = 'top'
     known_methods(2) = 'not'
     known_methods(3) = 'stop'
     if (extra_cmd == var_str ("")) return
     found = .false.
     do i = 1, N_KNOWN_SPECIAL_OL_METHODS
        found = found .or. &
             (extra_cmd == var_str ('extra approx ') // known_methods(i))
     end do
     if (.not. found) &
          call msg_fatal ("The given extra OpenLoops method is not kown ", &
          [var_str ("Available commands are: "), &
          var_str ("extra approx top (only WbWb signal),"), &
          var_str ("extra approx stop (only WbWb singletop),"), &
          var_str ("extra approx not (no top in WbWb).")])
   end subroutine check_extra_cmd
 
 @ %def check_extra_cmd
 @ This type contains the pdg code of the particle to be written in the process
 specification string and an optional additional information about the polarization
 of the particles. Note that the output can only be processed by OpenLoops.
 <<BLHA config: types>>=
   type :: blha_particle_string_element_t
      integer :: pdg = 0
      integer :: hel = OLP_HEL_UNPOLARIZED
      logical :: polarized = .false.
   contains
   <<BLHA config: blha particle string element: TBP>>
   end type blha_particle_string_element_t
 
 @ %def blha_particle_string_element_t
 @
 <<BLHA config: blha particle string element: TBP>>=
   generic :: init => init_default
   generic :: init => init_polarized
   procedure :: init_default => blha_particle_string_element_init_default
   procedure :: init_polarized => blha_particle_string_element_init_polarized
 <<BLHA config: procedures>>=
   subroutine blha_particle_string_element_init_default (blha_p, id)
     class(blha_particle_string_element_t), intent(out) :: blha_p
     integer, intent(in) :: id
     blha_p%pdg = id
   end subroutine blha_particle_string_element_init_default
 
 @ %def blha_particle_string_element_init_default
 @
 <<BLHA config: procedures>>=
   subroutine blha_particle_string_element_init_polarized (blha_p, id, hel)
     class(blha_particle_string_element_t), intent(out) :: blha_p
     integer, intent(in) :: id, hel
     blha_p%polarized = .true.
     blha_p%pdg = id
     blha_p%hel = hel
   end subroutine blha_particle_string_element_init_polarized
 
 @ %def blha_particle_string_element_init_polarized
 @
 <<BLHA config: blha particle string element: TBP>>=
   generic :: write_pdg => write_pdg_unit
   generic :: write_pdg => write_pdg_character
   procedure :: write_pdg_unit => blha_particle_string_element_write_pdg_unit
   procedure :: write_pdg_character &
        => blha_particle_string_element_write_pdg_character
 <<BLHA config: procedures>>=
   subroutine blha_particle_string_element_write_pdg_unit (blha_p, unit)
     class(blha_particle_string_element_t), intent(in) :: blha_p
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, '(I3)') blha_p%pdg
   end subroutine blha_particle_string_element_write_pdg_unit
 
 @ %def blha_particle_string_element_write_pdg_unit
 @
 <<BLHA config: procedures>>=
   subroutine blha_particle_string_element_write_pdg_character (blha_p, c)
     class(blha_particle_string_element_t), intent(in) :: blha_p
     character(3), intent(inout) :: c
     write (c, '(I3)') blha_p%pdg
   end subroutine blha_particle_string_element_write_pdg_character
 
 @ %def blha_particle_string_element_write_pdg_character
 @
 <<BLHA config: blha particle string element: TBP>>=
   generic :: write_helicity => write_helicity_unit
   generic :: write_helicity => write_helicity_character
   procedure :: write_helicity_unit &
        => blha_particle_string_element_write_helicity_unit
   procedure :: write_helicity_character &
        => blha_particle_string_element_write_helicity_character
 <<BLHA config: procedures>>=
   subroutine blha_particle_string_element_write_helicity_unit (blha_p, unit)
     class(blha_particle_string_element_t), intent(in) :: blha_p
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, '(A1,I0,A1)') '(', blha_p%hel, ')'
   end subroutine blha_particle_string_element_write_helicity_unit
 
 @ %def blha_particle_string_element_write_helicity_unit
 @
 <<BLHA config: procedures>>=
   subroutine blha_particle_string_element_write_helicity_character (blha_p, c)
     class(blha_particle_string_element_t), intent(in) :: blha_p
     character(4), intent(inout) :: c
     write (c, '(A1,I0,A1)') '(', blha_p%hel, ')'
   end subroutine blha_particle_string_element_write_helicity_character
 
 @ %def blha_particle_string_element_write_helicity_character
 @ This type encapsulates a BLHA request.
 <<BLHA config: public>>=
   public :: blha_configuration_t
   public :: blha_cfg_process_node_t
 <<BLHA config: types>>=
   type :: blha_cfg_process_node_t
      type(blha_particle_string_element_t), dimension(:), allocatable :: pdg_in, pdg_out
      integer, dimension(:), allocatable :: fingerprint
      integer :: nsub
      integer, dimension(:), allocatable :: ids
      integer :: amplitude_type
      type(blha_cfg_process_node_t), pointer :: next => null ()
   end type blha_cfg_process_node_t
 
   type :: blha_configuration_t
      type(string_t) :: name
      class(model_data_t), pointer :: model => null ()
      type(string_t) :: md5
      integer :: version = 2
      logical :: dirty = .false.
      integer :: n_proc = 0
      real(default) :: accuracy_target
      logical :: debug_unstable = .false.
      integer :: mode = BLHA_MODE_GENERIC
      logical :: polarized = .false.
      type(blha_cfg_process_node_t), pointer :: processes => null ()
      !integer, dimension(2) :: matrix_element_square_type = BLHA_MEST_SUM
      integer :: correction_type
      type(string_t) :: correction_type_other
      integer :: irreg = BLHA_IRREG_THV
      type(string_t) :: irreg_other
      integer :: massive_particle_scheme = BLHA_MPS_ONSHELL
      type(string_t) :: massive_particle_scheme_other
      type(string_t) :: model_file
      logical :: subdivide_subprocesses = .false.
      integer :: alphas_power = -1, alpha_power = -1
      integer :: ew_scheme = BLHA_EW_GF
      integer :: width_scheme = BLHA_WIDTH_DEFAULT
      logical :: openloops_use_cms = .false.
      integer :: openloops_phs_tolerance = 0
      type(string_t) :: openloops_extra_cmd
      integer :: openloops_stability_log = 0
   end type blha_configuration_t
 
 @ %def blha_cffg_process_node_t blha_configuration_t
 @ Translate the SINDARIN input string to the corresponding named integer.
 <<BLHA config: public>>=
   public :: ew_scheme_string_to_int
 <<BLHA config: procedures>>=
   function ew_scheme_string_to_int (ew_scheme_str) result (ew_scheme_int)
     integer :: ew_scheme_int
     type(string_t), intent(in) :: ew_scheme_str
     select case (char (ew_scheme_str))
     case ('GF', 'Gmu')
        ew_scheme_int = BLHA_EW_GF
     case ('alpha_qed', 'alpha_internal')
        ew_scheme_int = BLHA_EW_INTERNAL
     case ('alpha_mz')
        ew_scheme_int = BLHA_EW_MZ
     case ('alpha_0', 'alpha_thompson')
        ew_scheme_int = BLHA_EW_0
     case default
        call msg_fatal ("ew_scheme: " // char (ew_scheme_str) // &
             " not supported. Try 'Gmu', 'alpha_internal', 'alpha_mz' or 'alpha_0'.")
     end select
   end function ew_scheme_string_to_int
 
 @ %def ew_scheme_string_to_int
 @
 @ Translate the SINDARIN input string to the corresponding named integer
 denoting the type of NLO correction.
 <<BLHA config: public>>=
   public :: correction_type_string_to_int
 <<BLHA config: procedures>>=
   function correction_type_string_to_int (correction_type_str) result (correction_type_int)
     integer :: correction_type_int
     type(string_t), intent(in) :: correction_type_str
     select case (char (correction_type_str))
     case ('QCD')
        correction_type_int = BLHA_CT_QCD
     case ('EW')
        correction_type_int = BLHA_CT_EW
     case default
        call msg_warning ("nlo_correction_type: " // char (correction_type_str) // &
             " not supported. Try setting it to 'QCD', 'EW'.")
     end select
   end function correction_type_string_to_int
 
 @ %def correction_type_string_to_int
 @
 This types control the creation of BLHA-interface files
 <<BLHA config: public>>=
   public :: blha_flv_state_t
   public :: blha_master_t
 <<BLHA config: types>>=
   type:: blha_flv_state_t
     integer, dimension(:), allocatable :: flavors
     integer :: flv_mult
     logical :: flv_real = .false.
   end type blha_flv_state_t
 
   type :: blha_master_t
     integer, dimension(5) :: blha_mode = BLHA_MODE_GENERIC
     logical :: compute_borns = .false.
     logical :: compute_real_trees = .false.
     logical :: compute_loops = .true.
     logical :: compute_correlations = .false.
     logical :: compute_dglap = .false.
     integer :: ew_scheme
     type(string_t), dimension(:), allocatable :: suffix
     type(blha_configuration_t), dimension(:), allocatable :: blha_cfg
     integer :: n_files = 0
     integer, dimension(:), allocatable :: i_file_to_nlo_index
   contains
   <<BLHA config: blha master: TBP>>
   end type blha_master_t
 
 @ %def blha_flv_state_t, blha_master_t
 @ Master-Routines
 <<BLHA config: blha master: TBP>>=
   procedure :: set_methods => blha_master_set_methods
 <<BLHA config: procedures>>=
   subroutine blha_master_set_methods (master, is_nlo, var_list)
     class(blha_master_t), intent(inout) :: master
     logical, intent(in) :: is_nlo
     type(var_list_t), intent(in) :: var_list
     type(string_t) :: method, born_me_method, real_tree_me_method
     type(string_t) :: loop_me_method, correlation_me_method
     type(string_t) :: dglap_me_method
     type(string_t) :: default_method
     logical :: cmp_born, cmp_real
     logical :: cmp_loop, cmp_corr
     logical :: cmp_dglap
     if (is_nlo) then
        method = var_list%get_sval (var_str ("$method"))
        born_me_method = var_list%get_sval (var_str ("$born_me_method"))
        if (born_me_method == "")  born_me_method = method
        real_tree_me_method = var_list%get_sval (var_str ("$real_tree_me_method"))
        if (real_tree_me_method == "")  real_tree_me_method = method
        loop_me_method = var_list%get_sval (var_str ("$loop_me_method"))
        if (loop_me_method == "")  loop_me_method = method
        correlation_me_method = var_list%get_sval (var_str ("$correlation_me_method"))
        if (correlation_me_method == "")  correlation_me_method = method
        dglap_me_method = var_list%get_sval (var_str ("$dglap_me_method"))
        if (dglap_me_method == "")  dglap_me_method = method
        cmp_born = born_me_method /= 'omega'
        cmp_real = is_nlo .and. (real_tree_me_method /= 'omega')
        cmp_loop = is_nlo .and. (loop_me_method /= 'omega')
        cmp_corr = is_nlo .and. (correlation_me_method /= 'omega')
        cmp_dglap = is_nlo .and. (dglap_me_method /= 'omega')
        call set_me_method (1, loop_me_method)
        call set_me_method (2, correlation_me_method)
        call set_me_method (3, real_tree_me_method)
        call set_me_method (4, born_me_method)
        call set_me_method (5, dglap_me_method)
     else
        default_method = var_list%get_sval (var_str ("$method"))
        cmp_born = default_method /= 'omega'
        cmp_real = .false.; cmp_loop = .false.; cmp_corr = .false.
        call set_me_method (4, default_method)
     end if
     master%n_files = count ([cmp_born, cmp_real, cmp_loop, cmp_corr, cmp_dglap])
     call set_nlo_indices ()
     master%compute_borns = cmp_born
     master%compute_real_trees = cmp_real
     master%compute_loops = cmp_loop
     master%compute_correlations = cmp_corr
     master%compute_dglap = cmp_dglap
   contains
     subroutine set_nlo_indices ()
       integer :: i_file
       allocate (master%i_file_to_nlo_index (master%n_files))
       master%i_file_to_nlo_index = 0
       i_file = 0
       if (cmp_loop) then
          i_file = i_file + 1
          master%i_file_to_nlo_index(i_file) = 1
       end if
       if (cmp_corr) then
          i_file = i_file + 1
          master%i_file_to_nlo_index(i_file) = 2
       end if
       if (cmp_real) then
          i_file = i_file + 1
          master%i_file_to_nlo_index(i_file) = 3
       end if
       if (cmp_born) then
          i_file = i_file + 1
          master%i_file_to_nlo_index(i_file) = 4
       end if
       if (cmp_dglap) then
          i_file = i_file + 1
          master%i_file_to_nlo_index(i_file) = 5
       end if
     end subroutine set_nlo_indices
 
     subroutine set_me_method (i, me_method)
       integer, intent(in) :: i
       type(string_t) :: me_method
       select case (char (me_method))
       case ('gosam')
          call master%set_gosam (i)
       case ('openloops')
          call master%set_openloops (i)
       end select
     end subroutine set_me_method
   end subroutine blha_master_set_methods
 
 @ %def blha_master_set_methods
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: allocate_config_files => blha_master_allocate_config_files
 <<BLHA config: procedures>>=
   subroutine blha_master_allocate_config_files (master)
     class(blha_master_t), intent(inout) :: master
     allocate (master%blha_cfg (master%n_files))
     allocate (master%suffix (master%n_files))
   end subroutine blha_master_allocate_config_files
 @ %def blha_master_allocate_config_files
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: set_ew_scheme => blha_master_set_ew_scheme
 <<BLHA config: procedures>>=
   subroutine blha_master_set_ew_scheme (master, ew_scheme)
     class(blha_master_t), intent(inout) :: master
     type(string_t), intent(in) :: ew_scheme
     master%ew_scheme = ew_scheme_string_to_int (ew_scheme)
   end subroutine blha_master_set_ew_scheme
 
 @ %def blha_master_set_ew_scheme
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: set_correction_type => blha_master_set_correction_type
 <<BLHA config: procedures>>=
   subroutine blha_master_set_correction_type (master, correction_type_str)
     class(blha_master_t), intent(inout) :: master
     type(string_t), intent(in) :: correction_type_str
     master%blha_cfg(:)%correction_type = correction_type_string_to_int (correction_type_str)
   end subroutine blha_master_set_correction_type
 
 @ %def blha_master_set_correction_type
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: generate => blha_master_generate
 <<BLHA config: procedures>>=
   subroutine blha_master_generate (master, basename, model, &
          n_in, alpha_power, alphas_power, flv_born, flv_real)
     class(blha_master_t), intent(inout) :: master
     type(string_t), intent(in) :: basename
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in
     integer, intent(in) :: alpha_power, alphas_power
     integer, intent(in), dimension(:,:), allocatable :: flv_born, flv_real
     integer :: i_file
     if (master%n_files < 1) &
          call msg_fatal ("Attempting to generate OLP-files, but none are specified!")
     i_file = 1
     call master%generate_loop (basename, model, n_in, alpha_power, &
          alphas_power, flv_born, i_file)
     call master%generate_correlation (basename, model, n_in, alpha_power, &
          alphas_power, flv_born, i_file)
     call master%generate_real_tree (basename, model, n_in, alpha_power, &
          alphas_power, flv_real, i_file)
     call master%generate_born (basename, model, n_in, alpha_power, &
          alphas_power, flv_born, i_file)
     call master%generate_dglap (basename, model, n_in, alpha_power, &
          alphas_power, flv_born, i_file)
   end subroutine blha_master_generate
 
 @ %def blha_master_generate
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: generate_loop => blha_master_generate_loop
 <<BLHA config: procedures>>=
   subroutine blha_master_generate_loop (master, basename, model, n_in, &
          alpha_power, alphas_power, flv_born, i_file)
     class(blha_master_t), intent(inout) :: master
     type(string_t), intent(in) :: basename
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in
     integer, intent(in) :: alpha_power, alphas_power
     integer, dimension(:,:), allocatable, intent(in) :: flv_born
     integer, intent(inout) :: i_file
     type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
     integer :: i_flv
     if (master%compute_loops) then
        if (allocated (flv_born)) then
           allocate (blha_flavor (size (flv_born, 2)))
           do i_flv = 1, size (flv_born, 2)
              allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv))))
              blha_flavor(i_flv)%flavors = flv_born(:,i_flv)
              blha_flavor(i_flv)%flv_mult = 2
           end do
           master%suffix(i_file) = blha_get_additional_suffix (var_str ("_LOOP"))
           call blha_init_virtual (master%blha_cfg(i_file), blha_flavor, &
                n_in, alpha_power, alphas_power, master%ew_scheme, &
                basename, model, master%blha_mode(1), master%suffix(i_file))
           i_file = i_file + 1
         else
           call msg_fatal ("BLHA Loops requested but " &
                // "Born flavor not existing")
         end if
     end if
   end subroutine blha_master_generate_loop
 
 @ %def blha_master_generate_loop
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: generate_correlation => blha_master_generate_correlation
 <<BLHA config: procedures>>=
   subroutine blha_master_generate_correlation (master, basename, model, n_in, &
          alpha_power, alphas_power, flv_born, i_file)
     class(blha_master_t), intent(inout) :: master
     type(string_t), intent(in) :: basename
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in
     integer, intent(in) :: alpha_power, alphas_power
     integer, dimension(:,:), allocatable, intent(in) :: flv_born
     integer, intent(inout) :: i_file
     type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
     integer :: i_flv
     if (master%compute_correlations) then
        if (allocated (flv_born)) then
           allocate (blha_flavor (size (flv_born, 2)))
           do i_flv = 1, size (flv_born, 2)
              allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv))))
              blha_flavor(i_flv)%flavors = flv_born(:,i_flv)
              blha_flavor(i_flv)%flv_mult = 3
           end do
           master%suffix(i_file) = blha_get_additional_suffix (var_str ("_SUB"))
           call blha_init_subtraction (master%blha_cfg(i_file), blha_flavor, &
                n_in, alpha_power, alphas_power, master%ew_scheme, &
                basename, model, master%blha_mode(2), master%suffix(i_file))
           i_file = i_file + 1
        else
           call msg_fatal ("BLHA Correlations requested but "&
                // "Born flavor not existing")
        end if
     end if
   end subroutine blha_master_generate_correlation
 
 @ %def blha_master_generate_correlation
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: generate_real_tree => blha_master_generate_real_tree
 <<BLHA config: procedures>>=
   subroutine blha_master_generate_real_tree (master, basename, model, n_in, &
          alpha_power, alphas_power, flv_real, i_file)
     class(blha_master_t), intent(inout) :: master
     type(string_t), intent(in) :: basename
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in
     integer, intent(in) :: alpha_power, alphas_power
     integer, dimension(:,:), allocatable, intent(in) :: flv_real
     integer, intent(inout) :: i_file
     type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
     integer :: i_flv
     if (master%compute_real_trees) then
        if (allocated (flv_real)) then
           allocate (blha_flavor (size (flv_real, 2)))
           do i_flv = 1, size (flv_real, 2)
              allocate (blha_flavor(i_flv)%flavors (size (flv_real(:,i_flv))))
              blha_flavor(i_flv)%flavors = flv_real(:,i_flv)
              blha_flavor(i_flv)%flv_mult = 1
           end do
           master%suffix(i_file) = blha_get_additional_suffix (var_str ("_REAL"))
           call blha_init_real (master%blha_cfg(i_file), blha_flavor, &
                n_in, alpha_power, alphas_power, master%ew_scheme, &
                basename, model, master%blha_mode(3), master%suffix(i_file))
           i_file = i_file + 1
        else
           call msg_fatal ("BLHA Trees requested but "&
                // "Real flavor not existing")
        end if
     end if
   end subroutine blha_master_generate_real_tree
 
 @ %def blha_master_generate_real_tree
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: generate_born => blha_master_generate_born
 <<BLHA config: procedures>>=
 subroutine blha_master_generate_born (master, basename, model, n_in, &
        alpha_power, alphas_power, flv_born, i_file)
     class(blha_master_t), intent(inout) :: master
     type(string_t), intent(in) :: basename
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in
     integer, intent(in) :: alpha_power, alphas_power
     integer, dimension(:,:), allocatable, intent(in) :: flv_born
     integer, intent(inout) :: i_file
     type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
     integer :: i_flv
     if (master%compute_borns) then
        if (allocated (flv_born)) then
           allocate (blha_flavor (size (flv_born, 2)))
           do i_flv = 1, size (flv_born, 2)
              allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv))))
              blha_flavor(i_flv)%flavors = flv_born(:,i_flv)
              blha_flavor(i_flv)%flv_mult = 1
           end do
           master%suffix(i_file) = blha_get_additional_suffix (var_str ("_BORN"))
           call blha_init_born (master%blha_cfg(i_file), blha_flavor, &
                n_in, alpha_power, alphas_power, master%ew_scheme, &
                basename, model, master%blha_mode(4), master%suffix(i_file))
           i_file = i_file + 1
        end if
     end if
   end subroutine blha_master_generate_born
 
 @ %def blha_master_generate_born
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: generate_dglap => blha_master_generate_dglap
 <<BLHA config: procedures>>=
 subroutine blha_master_generate_dglap (master, basename, model, n_in, &
        alpha_power, alphas_power, flv_born, i_file)
     class(blha_master_t), intent(inout) :: master
     type(string_t), intent(in) :: basename
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in
     integer, intent(in) :: alpha_power, alphas_power
     integer, dimension(:,:), allocatable, intent(in) :: flv_born
     integer, intent(inout) :: i_file
     type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor
     integer :: i_flv
     if (master%compute_dglap) then
        if (allocated (flv_born)) then
           allocate (blha_flavor (size (flv_born, 2)))
           do i_flv = 1, size (flv_born, 2)
              allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv))))
              blha_flavor(i_flv)%flavors = flv_born(:,i_flv)
              blha_flavor(i_flv)%flv_mult = 1
           end do
           master%suffix(i_file) = blha_get_additional_suffix (var_str ("_DGLAP"))
           call blha_init_born (master%blha_cfg(i_file), blha_flavor, &
                n_in, alpha_power, alphas_power, master%ew_scheme, &
                basename, model, master%blha_mode(5), master%suffix(i_file))
           i_file = i_file + 1
        end if
     end if
   end subroutine blha_master_generate_dglap
 
 @ %def blha_master_generate_dglap
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: setup_additional_features => blha_master_setup_additional_features
 <<BLHA config: procedures>>=
   subroutine blha_master_setup_additional_features (master, &
          phs_tolerance, use_cms, stability_log, extra_cmd, beam_structure)
      class(blha_master_t), intent(inout) :: master
      integer, intent(in) :: phs_tolerance
      logical, intent(in) :: use_cms
      type(string_t), intent(in), optional :: extra_cmd
      integer, intent(in) :: stability_log
      type(beam_structure_t), intent(in), optional :: beam_structure
      integer :: i_file
      logical :: polarized, throw_warning
 
      polarized = .false.
      if (present (beam_structure)) polarized = beam_structure%has_polarized_beams ()
 
      throw_warning = .false.
      if (use_cms) then
         throw_warning = throw_warning .or. (master%compute_loops &
              .and. master%blha_mode(1) /= BLHA_MODE_OPENLOOPS)
         throw_warning = throw_warning .or. (master%compute_correlations &
              .and. master%blha_mode(2) /= BLHA_MODE_OPENLOOPS)
         throw_warning = throw_warning .or. (master%compute_real_trees &
              .and. master%blha_mode(3) /= BLHA_MODE_OPENLOOPS)
         throw_warning = throw_warning .or. (master%compute_borns &
              .and. master%blha_mode(4) /= BLHA_MODE_OPENLOOPS)
         throw_warning = throw_warning .or. (master%compute_dglap &
              .and. master%blha_mode(5) /= BLHA_MODE_OPENLOOPS)
         if (throw_warning)  call cms_warning ()
      end if
 
      do i_file = 1, master%n_files
         if (phs_tolerance > 0) then
            select case (master%blha_mode (master%i_file_to_nlo_index(i_file)))
            case (BLHA_MODE_GOSAM)
               if (polarized)  call gosam_error_message ()
            case (BLHA_MODE_OPENLOOPS)
               master%blha_cfg(i_file)%openloops_use_cms = use_cms
               master%blha_cfg(i_file)%openloops_phs_tolerance = phs_tolerance
               master%blha_cfg(i_file)%polarized = polarized
               if (present (extra_cmd)) then
                  master%blha_cfg(i_file)%openloops_extra_cmd = extra_cmd
               else
                  master%blha_cfg(i_file)%openloops_extra_cmd = var_str ('')
               end if
               master%blha_cfg(i_file)%openloops_stability_log = stability_log
            end select
         end if
      end do
   contains
      subroutine cms_warning ()
         call msg_warning ("You have set ?openloops_use_cms = true, but not all active matrix ", &
              [var_str ("element methods are set to OpenLoops. Note that other "), &
              var_str ("methods might not necessarily support the complex mass "), &
              var_str ("scheme. This can yield inconsistencies in your NLO results!")])
      end subroutine cms_warning
 
      subroutine gosam_error_message ()
         call msg_fatal ("You are trying to evaluate a process at NLO ", &
              [var_str ("which involves polarized beams using GoSam. "), &
              var_str ("This feature is not supported yet. "), &
              var_str ("Please use OpenLoops instead")])
      end subroutine gosam_error_message
   end subroutine blha_master_setup_additional_features
 
 @ %def blha_master_setup_additional_features
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: set_gosam => blha_master_set_gosam
 <<BLHA config: procedures>>=
   subroutine blha_master_set_gosam (master, i)
     class(blha_master_t), intent(inout) :: master
     integer, intent(in) :: i
     master%blha_mode(i) = BLHA_MODE_GOSAM
   end subroutine blha_master_set_gosam
 
 @ %def blha_master_set_gosam
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: set_openloops => blha_master_set_openloops
 <<BLHA config: procedures>>=
   subroutine blha_master_set_openloops (master, i)
     class(blha_master_t), intent(inout) :: master
     integer, intent(in) :: i
     master%blha_mode(i) = BLHA_MODE_OPENLOOPS
   end subroutine blha_master_set_openloops
 
 @ %def blha_master_set_openloops
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: set_polarization => blha_master_set_polarization
 <<BLHA config: procedures>>=
   subroutine blha_master_set_polarization (master, i)
     class(blha_master_t), intent(inout) :: master
     integer, intent(in) :: i
     master%blha_cfg(i)%polarized = .true.
   end subroutine blha_master_set_polarization
 
 @ %def blha_master_set_polarization
 @
 <<BLHA config: procedures>>=
   subroutine blha_init_born (blha_cfg, blha_flavor, n_in, &
          ap, asp, ew_scheme, basename, model, blha_mode, suffix)
     type(blha_configuration_t), intent(inout) :: blha_cfg
     type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
     integer, intent(in) :: n_in
     integer, intent(in) :: ap, asp
     integer, intent(in) :: ew_scheme
     type(string_t), intent(in) :: basename
     type(model_data_t), intent(in), target :: model
     integer, intent(in) :: blha_mode
     type(string_t), intent(in) :: suffix
     integer, dimension(:), allocatable :: amp_type
     integer :: i
 
     allocate (amp_type (size (blha_flavor)))
     do i = 1, size (blha_flavor)
        amp_type(i) = BLHA_AMP_TREE
     end do
     call blha_configuration_init (blha_cfg, basename // suffix , &
          model, blha_mode)
     call blha_configuration_append_processes (blha_cfg, n_in, &
          blha_flavor, amp_type)
     call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
          irreg = BLHA_IRREG_CDR, alphas_power = asp, &
          alpha_power = ap, ew_scheme = ew_scheme, &
          debug = blha_mode == BLHA_MODE_GOSAM)
   end subroutine blha_init_born
 
   subroutine blha_init_virtual (blha_cfg, blha_flavor, n_in, &
          ap, asp, ew_scheme, basename, model, blha_mode, suffix)
     type(blha_configuration_t), intent(inout) :: blha_cfg
     type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
     integer, intent(in) :: n_in
     integer, intent(in) :: ap, asp
     integer, intent(in) :: ew_scheme
     type(string_t), intent(in) :: basename
     type(model_data_t), intent(in), target :: model
     integer, intent(in) :: blha_mode
     type(string_t), intent(in) :: suffix
     integer, dimension(:), allocatable :: amp_type
     integer :: i
 
     allocate (amp_type (size (blha_flavor) * 2))
     do i = 1, size (blha_flavor)
        amp_type(2 * i - 1) = BLHA_AMP_LOOP
        amp_type(2 * i) = BLHA_AMP_COLOR_C
     end do
     call blha_configuration_init (blha_cfg, basename // suffix , &
          model, blha_mode)
     call blha_configuration_append_processes (blha_cfg, n_in, &
          blha_flavor, amp_type)
     call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
          irreg = BLHA_IRREG_CDR, &
          alphas_power = asp, &
          alpha_power = ap, &
          ew_scheme = ew_scheme, &
          debug = blha_mode == BLHA_MODE_GOSAM)
   end subroutine blha_init_virtual
 
   subroutine blha_init_subtraction (blha_cfg, blha_flavor, n_in, &
          ap, asp, ew_scheme, basename, model, blha_mode, suffix)
     type(blha_configuration_t), intent(inout) :: blha_cfg
     type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
     integer, intent(in) :: n_in
     integer, intent(in) :: ap, asp
     integer, intent(in) :: ew_scheme
     type(string_t), intent(in) :: basename
     type(model_data_t), intent(in), target :: model
     integer, intent(in) :: blha_mode
     type(string_t), intent(in) :: suffix
     integer, dimension(:), allocatable :: amp_type
     integer :: i
 
     allocate (amp_type (size (blha_flavor) * 3))
     do i = 1, size (blha_flavor)
        amp_type(3 * i - 2) = BLHA_AMP_TREE
        amp_type(3 * i - 1) = BLHA_AMP_COLOR_C
        amp_type(3 * i) = BLHA_AMP_SPIN_C
     end do
     call blha_configuration_init (blha_cfg, basename // suffix , &
          model, blha_mode)
     call blha_configuration_append_processes (blha_cfg, n_in, &
          blha_flavor, amp_type)
     call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
          irreg = BLHA_IRREG_CDR, &
          alphas_power = asp, &
          alpha_power = ap, &
          ew_scheme = ew_scheme, &
          debug = blha_mode == BLHA_MODE_GOSAM)
   end subroutine blha_init_subtraction
 
   subroutine blha_init_real (blha_cfg, blha_flavor, n_in, &
          ap, asp, ew_scheme, basename, model, blha_mode, suffix)
     type(blha_configuration_t), intent(inout) :: blha_cfg
     type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor
     integer, intent(in) :: n_in
     integer, intent(in) :: ap, asp
     integer :: ap_ew, ap_qcd
     integer, intent(in) :: ew_scheme
     type(string_t), intent(in) :: basename
     type(model_data_t), intent(in), target :: model
     integer, intent(in) :: blha_mode
     type(string_t), intent(in) :: suffix
     integer, dimension(:), allocatable :: amp_type
     integer :: i
 
     allocate (amp_type (size (blha_flavor)))
     do i = 1, size (blha_flavor)
        amp_type(i) = BLHA_AMP_TREE
     end do
     select case (blha_cfg%correction_type)
     case (BLHA_CT_QCD)
        ap_ew = ap
        ap_qcd = asp + 1
     case (BLHA_CT_EW)
        ap_ew = ap + 1
        ap_qcd = asp
     end select
     call blha_configuration_init (blha_cfg, basename // suffix , &
          model, blha_mode)
     call blha_configuration_append_processes (blha_cfg, n_in, &
          blha_flavor, amp_type)
 
     call blha_configuration_set (blha_cfg, BLHA_VERSION_2, &
          irreg = BLHA_IRREG_CDR, &
          alphas_power = ap_qcd, &
          alpha_power = ap_ew, &
          ew_scheme = ew_scheme, &
          debug = blha_mode == BLHA_MODE_GOSAM)
   end subroutine blha_init_real
 
 @ %def blha_init_virtual blha_init_real
 @ %def blha_init_subtraction
 @
 <<BLHA config: public>>=
   public :: blha_get_additional_suffix
 <<BLHA config: procedures>>=
   function blha_get_additional_suffix (base_suffix) result (suffix)
     type(string_t) :: suffix
     type(string_t), intent(in) :: base_suffix
   <<blha master: blha master extend suffixes: variables>>
     suffix = base_suffix
   <<blha master: blha master extend suffixes: procedure>>
   end function blha_get_additional_suffix
 
 @ %def blha_master_extend_suffixes
 @
 <<MPI: blha master: blha master extend suffixes: variables>>=
   integer :: n_size, rank
 <<MPI: blha master: blha master extend suffixes: procedure>>=
   call MPI_Comm_rank (MPI_COMM_WORLD, rank)
   call MPI_Comm_size (MPI_COMM_WORLD, n_size)
   if (n_size > 1) then
      suffix = suffix // var_str ("_") // str (rank)
   end if
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: write_olp => blha_master_write_olp
 <<BLHA config: procedures>>=
   subroutine blha_master_write_olp (master, basename)
     class(blha_master_t), intent(in) :: master
     type(string_t), intent(in) :: basename
     integer :: unit
     type(string_t) :: filename
     integer :: i_file
     do i_file = 1, master%n_files
        filename = basename // master%suffix(i_file) // ".olp"
        unit = free_unit ()
        open (unit, file = char (filename), status = 'replace', action = 'write')
        call blha_configuration_write (master%blha_cfg(i_file), unit)
        close (unit)
     end do
   end subroutine blha_master_write_olp
 
 @ %def blha_master_write_olp
 @
 <<BLHA config: blha master: TBP>>=
   procedure :: final => blha_master_final
 <<BLHA config: procedures>>=
   subroutine blha_master_final (master)
     class(blha_master_t), intent(inout) :: master
     master%n_files = 0
     deallocate (master%suffix)
     deallocate (master%blha_cfg)
     deallocate (master%i_file_to_nlo_index)
   end subroutine blha_master_final
 
 @ %def blha_master_final
 @
 <<BLHA config: public>>=
   public :: blha_configuration_init
 <<BLHA config: procedures>>=
   subroutine blha_configuration_init (cfg, name, model, mode)
     type(blha_configuration_t), intent(inout) :: cfg
     type(string_t), intent(in) :: name
     class(model_data_t), target, intent(in) :: model
     integer, intent(in), optional :: mode
     if (.not. associated (cfg%model)) then
        cfg%name = name
        cfg%model => model
     end if
     if (present (mode))  cfg%mode = mode
   end subroutine blha_configuration_init
 
 @ %def blha_configuration_init
 @ Create an array of massive particle indices, to be used by the
 "MassiveParticle"-statement of the order file.
 <<BLHA config: procedures>>=
   subroutine blha_configuration_get_massive_particles &
          (cfg, massive, i_massive)
     type(blha_configuration_t), intent(in) :: cfg
     logical, intent(out) :: massive
     integer, intent(out), dimension(:), allocatable :: i_massive
     integer, parameter :: max_particles = 10
     integer, dimension(max_particles) :: i_massive_tmp
     integer, dimension(max_particles) :: checked
     type(blha_cfg_process_node_t), pointer :: current_process
     integer :: k
     integer :: n_massive
     n_massive = 0; k = 1
     checked = 0
     if (associated (cfg%processes)) then
        current_process => cfg%processes
     else
        call msg_fatal ("BLHA, massive particles: " // &
             "No processes allocated!")
     end if
     do
        call check_pdg_list (current_process%pdg_in%pdg)
        call check_pdg_list (current_process%pdg_out%pdg)
        if (k > max_particles) &
             call msg_fatal ("BLHA, massive particles: " // &
             "Max. number of particles exceeded!")
        if (associated (current_process%next)) then
           current_process => current_process%next
        else
           exit
        end if
     end do
     if (n_massive > 0) then
        allocate (i_massive (n_massive))
        i_massive = i_massive_tmp (1:n_massive)
        massive = .true.
     else
        massive = .false.
     end if
   contains
     subroutine check_pdg_list (pdg_list)
        integer, dimension(:), intent(in) :: pdg_list
        integer :: i, i_pdg
        type(flavor_t) :: flv
        do i = 1, size (pdg_list)
           i_pdg = abs (pdg_list(i))
           call flv%init (i_pdg, cfg%model)
           if (flv%get_mass () > 0._default) then
              !!! Avoid duplicates in output
              if (.not. any (checked == i_pdg)) then
                 i_massive_tmp(k) = i_pdg
                 checked(k) = i_pdg
                 k = k + 1
                 n_massive = n_massive + 1
              end if
           end if
        end do
     end subroutine check_pdg_list
   end subroutine blha_configuration_get_massive_particles
 
 @ %def blha_configuration_get_massive_particles
 @
 <<BLHA config: public>>=
   public :: blha_configuration_append_processes
 <<BLHA config: procedures>>=
   subroutine blha_configuration_append_processes (cfg, n_in, flavor, amp_type)
     type(blha_configuration_t), intent(inout) :: cfg
     integer, intent(in) :: n_in
     type(blha_flv_state_t), dimension(:), intent(in) :: flavor
     integer, dimension(:), intent(in), optional :: amp_type
     integer :: n_tot
     type(blha_cfg_process_node_t), pointer :: current_node
     integer :: i_process, i_flv
     integer, dimension(:), allocatable :: pdg_in, pdg_out
     integer, dimension(:), allocatable :: flavor_state
     integer :: proc_offset, n_proc_tot
     proc_offset = 0; n_proc_tot = 0
     do i_flv = 1, size (flavor)
        n_proc_tot = n_proc_tot + flavor(i_flv)%flv_mult
     end do
     if (.not. associated (cfg%processes)) &
          allocate (cfg%processes)
     current_node => cfg%processes
     do i_flv = 1, size (flavor)
        n_tot = size (flavor(i_flv)%flavors)
        allocate (pdg_in (n_in), pdg_out (n_tot - n_in))
        allocate (flavor_state (n_tot))
        flavor_state = flavor(i_flv)%flavors
        do i_process = 1, flavor(i_flv)%flv_mult
           pdg_in = flavor_state (1 : n_in)
           pdg_out = flavor_state (n_in + 1 : )
           if (cfg%polarized) then
              select case (cfg%mode)
              case (BLHA_MODE_OPENLOOPS)
                 call allocate_and_init_pdg_and_helicities (current_node, &
                      pdg_in, pdg_out, amp_type (proc_offset + i_process))
              case (BLHA_MODE_GOSAM)
                 !!! Nothing special for GoSam yet. This exception is already caught
                 !!! in blha_master_setup_additional_features
              end select
           else
              call allocate_and_init_pdg (current_node, pdg_in, pdg_out, &
                   amp_type (proc_offset + i_process))
           end if
           if (proc_offset + i_process /= n_proc_tot) then
             allocate (current_node%next)
             current_node => current_node%next
           end if
           if (i_process == flavor(i_flv)%flv_mult) &
                proc_offset = proc_offset + flavor(i_flv)%flv_mult
        end do
        deallocate (pdg_in, pdg_out)
        deallocate (flavor_state)
     end do
 
   contains
 
     subroutine allocate_and_init_pdg (node, pdg_in, pdg_out, amp_type)
       type(blha_cfg_process_node_t), intent(inout), pointer :: node
       integer, intent(in), dimension(:), allocatable :: pdg_in, pdg_out
       integer, intent(in) :: amp_type
       allocate (node%pdg_in (size (pdg_in)))
       allocate (node%pdg_out (size (pdg_out)))
       node%pdg_in%pdg = pdg_in
       node%pdg_out%pdg = pdg_out
       node%amplitude_type = amp_type
     end subroutine allocate_and_init_pdg
 
     subroutine allocate_and_init_pdg_and_helicities (node, pdg_in, pdg_out, amp_type)
       type(blha_cfg_process_node_t), intent(inout), pointer :: node
       integer, intent(in), dimension(:), allocatable :: pdg_in, pdg_out
       integer, intent(in) :: amp_type
       integer :: h1, h2
       if (size (pdg_in) == 2) then
          do h1 = -1, 1, 2
             do h2 = -1, 1, 2
                call allocate_and_init_pdg (current_node, pdg_in, pdg_out, amp_type)
                current_node%pdg_in(1)%polarized = .true.
                current_node%pdg_in(2)%polarized = .true.
                current_node%pdg_in(1)%hel = h1
                current_node%pdg_in(2)%hel = h2
                if (h1 + h2 /= 2) then !!! not end of loop
                   allocate (current_node%next)
                   current_node => current_node%next
                end if
             end do
          end do
       else
          do h1 = -1, 1, 2
             call allocate_and_init_pdg (current_node, pdg_in, pdg_out, amp_type)
             current_node%pdg_in(1)%polarized = .true.
             current_node%pdg_in(1)%hel = h1
             if (h1 /= 1) then !!! not end of loop
                allocate (current_node%next)
                current_node => current_node%next
             end if
          end do
       end if
     end subroutine allocate_and_init_pdg_and_helicities
 
   end subroutine blha_configuration_append_processes
 
 @ %def blha_configuration_append_processes
 @ Change parameter(s).
 <<BLHA config: public>>=
   public :: blha_configuration_set
 <<BLHA config: procedures>>=
   subroutine blha_configuration_set (cfg, &
          version, irreg, massive_particle_scheme, &
          model_file, alphas_power, alpha_power, ew_scheme, width_scheme, &
          accuracy, debug)
     type(blha_configuration_t), intent(inout) :: cfg
     integer, optional, intent(in) :: version
     integer, optional, intent(in) :: irreg
     integer, optional, intent(in) :: massive_particle_scheme
     type(string_t), optional, intent(in) :: model_file
     integer, optional, intent(in) :: alphas_power, alpha_power
     integer, optional, intent(in) :: ew_scheme
     integer, optional, intent(in) :: width_scheme
     real(default), optional, intent(in) :: accuracy
     logical, optional, intent(in) :: debug
     if (present (version)) &
          cfg%version = version
     if (present (irreg)) &
          cfg%irreg = irreg
     if (present (massive_particle_scheme)) &
          cfg%massive_particle_scheme = massive_particle_scheme
     if (present (model_file)) &
          cfg%model_file = model_file
     if (present (alphas_power)) &
          cfg%alphas_power = alphas_power
     if (present (alpha_power)) &
          cfg%alpha_power = alpha_power
     if (present (ew_scheme)) &
          cfg%ew_scheme = ew_scheme
     if (present (width_scheme)) &
          cfg%width_scheme = width_scheme
     if (present (accuracy)) &
          cfg%accuracy_target = accuracy
     if (present (debug)) &
          cfg%debug_unstable = debug
     cfg%dirty = .false.
   end subroutine blha_configuration_set
 
 @ %def blha_configuration_set
 @
 <<BLHA config: public>>=
   public :: blha_configuration_get_n_proc
 <<BLHA config: procedures>>=
   function blha_configuration_get_n_proc (cfg) result (n_proc)
     type(blha_configuration_t), intent(in) :: cfg
     integer :: n_proc
     n_proc = cfg%n_proc
   end function blha_configuration_get_n_proc
 
 @ %def blha_configuration_get_n_proc
 @
 Write the BLHA file. Internal mode is intented for md5summing only.
 <<BLHA config: public>>=
   public :: blha_configuration_write
 <<BLHA config: procedures>>=
   subroutine blha_configuration_write (cfg, unit, internal, no_version)
     type(blha_configuration_t), intent(in) :: cfg
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: internal, no_version
     integer :: u
     logical :: full
     type(string_t) :: buf
     type(blha_cfg_process_node_t), pointer :: node
     integer :: i
     character(3) :: pdg_char
     character(4) :: hel_char
     character(len=25), parameter :: pad = ""
     logical :: write_process, no_v
     no_v = .false. ; if (present (no_version))  no_v = no_version
     u = given_output_unit (unit); if (u < 0) return
     full = .true.; if (present (internal)) full = .not. internal
     if (full .and. cfg%dirty) call msg_bug ( &
          "BUG: attempted to write out a dirty BLHA configuration")
     if (full) then
        if (no_v) then
           write (u, "(A)") "# BLHA order written by WHIZARD [version]"
        else
           write (u, "(A)") "# BLHA order written by WHIZARD <<Version>>"
        end if
        write (u, "(A)")
     end if
     select case (cfg%mode)
        case (BLHA_MODE_GOSAM); buf = "GoSam"
        case (BLHA_MODE_OPENLOOPS); buf = "OpenLoops"
        case default; buf = "vanilla"
     end select
     write (u, "(A)") "# BLHA interface mode: " // char (buf)
     write (u, "(A)") "# process: " // char (cfg%name)
     write (u, "(A)") "# model: " // char (cfg%model%get_name ())
     select case (cfg%version)
        case (1); buf = "BLHA1"
        case (2); buf = "BLHA2"
     end select
     write (u, '(A25,A)') "InterfaceVersion " // pad, char (buf)
     select case (cfg%correction_type)
        case (BLHA_CT_QCD); buf = "QCD"
        case (BLHA_CT_EW); buf = "EW"
        case default; buf = cfg%correction_type_other
     end select
     write (u,'(A25,A)') "CorrectionType" // pad, char (buf)
 
     select case (cfg%mode)
     case (BLHA_MODE_OPENLOOPS)
        buf = cfg%name // '.olc'
        write (u, '(A25,A)') "Extra AnswerFile" // pad, char (buf)
     end select
 
     select case (cfg%irreg)
        case (BLHA_IRREG_CDR); buf = "CDR"
        case (BLHA_IRREG_DRED); buf = "DRED"
        case (BLHA_IRREG_THV); buf = "tHV"
        case (BLHA_IRREG_MREG); buf = "MassReg"
        case default; buf = cfg%irreg_other
     end select
     write (u,'(A25,A)') "IRregularisation" // pad, char (buf)
     select case (cfg%massive_particle_scheme)
        case (BLHA_MPS_ONSHELL); buf = "OnShell"
        case default; buf = cfg%massive_particle_scheme_other
     end select
     if (cfg%mode == BLHA_MODE_GOSAM) &
          write (u,'(A25,A)') "MassiveParticleScheme" // pad, char (buf)
     select case (cfg%version)
     case (1)
       if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
            "AlphasPower" // pad, int2char (cfg%alphas_power)
       if (cfg%alpha_power >= 0) write (u,'(A25,A)') &
            "AlphaPower " // pad, int2char (cfg%alpha_power)
     case (2)
       if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
            "CouplingPower QCD " // pad, int2char (cfg%alphas_power)
       if (cfg%alpha_power >= 0) write (u, '(A25,A)') &
            "CouplingPower QED " // pad, int2char (cfg%alpha_power)
     end select
     select case (cfg%mode)
     case (BLHA_MODE_GOSAM)
        select case (cfg%ew_scheme)
           case (BLHA_EW_GF, BLHA_EW_INTERNAL); buf = "alphaGF"
           case (BLHA_EW_MZ); buf = "alphaMZ"
           case (BLHA_EW_MSBAR); buf = "alphaMSbar"
           case (BLHA_EW_0); buf = "alpha0"
           case (BLHA_EW_RUN); buf = "alphaRUN"
        end select
        write (u, '(A25, A)') "EWScheme " // pad, char (buf)
     case (BLHA_MODE_OPENLOOPS)
        select case (cfg%ew_scheme)
           case (BLHA_EW_0); buf = "alpha0"
           case (BLHA_EW_GF); buf = "Gmu"
           case (BLHA_EW_MZ, BLHA_EW_INTERNAL); buf = "alphaMZ"
           case default
              call msg_fatal ("OpenLoops input: Only supported EW schemes &
                   & are 'alpha0', 'Gmu', and 'alphaMZ'")
           end select
        write (u, '(A25, A)') "ewscheme " // pad, char (buf)
     end select
     select case (cfg%mode)
     case (BLHA_MODE_GOSAM)
        write (u, '(A25)', advance='no') "MassiveParticles " // pad
        do i = 1, size (OLP_MASSIVE_PARTICLES)
           if (OLP_MASSIVE_PARTICLES(i) > 0) &
                write (u, '(I2,1X)', advance='no') OLP_MASSIVE_PARTICLES(i)
        end do
        write (u,*)
     case (BLHA_MODE_OPENLOOPS)
        if (cfg%openloops_use_cms) then
           write (u, '(A25,I1)') "extra use_cms " // pad, 1
        else
           write (u, '(A25,I1)') "extra use_cms " // pad, 0
        end if
        write (u, '(A25,I1)') "extra me_cache " // pad, 0
        !!! Turn off calculation of 1/eps & 1/eps^2 poles in one-loop calculation
        !!! Not needed in FKS (or any numerical NLO subtraction scheme)
        write (u, '(A25,I1)') "extra IR_on " // pad, 0
        if (cfg%openloops_phs_tolerance > 0) then
           write (u, '(A25,A4,I0)') "extra psp_tolerance " // pad, "10e-", &
                cfg%openloops_phs_tolerance
        end if
        call check_extra_cmd (cfg%openloops_extra_cmd)
        write (u, '(A)') char (cfg%openloops_extra_cmd)
        if (cfg%openloops_stability_log > 0) &
             write (u, '(A25,I1)') "extra stability_log " // pad, &
             cfg%openloops_stability_log
     end select
     if (full) then
        write (u, "(A)")
        write (u, "(A)") "# Process definitions"
        write (u, "(A)")
     end if
     if (cfg%debug_unstable) &
          write (u, '(A25,A)') "DebugUnstable " // pad, "True"
     write (u, *)
     node => cfg%processes
     do while (associated (node))
        write_process = .true.
        select case (node%amplitude_type)
          case (BLHA_AMP_LOOP); buf = "Loop"
          case (BLHA_AMP_COLOR_C); buf = "ccTree"
          case (BLHA_AMP_SPIN_C)
             if (cfg%mode == BLHA_MODE_OPENLOOPS) then
                buf = "sctree_polvect"
             else
                buf = "scTree"
             end if
          case (BLHA_AMP_TREE); buf = "Tree"
          case (BLHA_AMP_LOOPINDUCED); buf = "LoopInduced"
        end select
        if (write_process) then
           write (u, '(A25, A)') "AmplitudeType " // pad, char (buf)
           buf = ""
           do i = 1, size (node%pdg_in)
              call node%pdg_in(i)%write_pdg (pdg_char)
              if (node%pdg_in(i)%polarized) then
                 call node%pdg_in(i)%write_helicity (hel_char)
                 buf = (buf // pdg_char // hel_char) // " "
              else
                 buf = (buf // pdg_char) // " "
              end if
           end do
           buf = buf // "-> "
           do i = 1, size (node%pdg_out)
              call node%pdg_out(i)%write_pdg (pdg_char)
              buf = (buf // pdg_char) // " "
           end do
           write (u, "(A)") char (trim (buf))
           write (u, *)
        end if
        node => node%next
     end do
 
   end subroutine blha_configuration_write
 
 @ %def blha_configuration_write
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[blha_ut.f90]]>>=
 <<File header>>
 
 module blha_ut
   use unit_tests
   use blha_uti
 
 <<Standard module head>>
 
 <<BLHA: public tests>>
 
 contains
 
 <<BLHA: test driver>>
 
 end module blha_ut
 
 @ %def blha_ut
 @
 <<[[blha_uti.f90]]>>=
 <<File header>>
 
 module blha_uti
 
 <<Use strings>>
   use format_utils, only: write_separator
   use variables, only: var_list_t
   use os_interface
   use models
   use blha_config
 
 
 <<Standard module head>>
 
 <<BLHA: test declarations>>
 
 contains
 
 <<BLHA: test procedures>>
 
 <<BLHA: tests>>
 
 end module blha_uti
 
 @ %def blha_uti
 @ API: driver for the unit tests below.
 <<BLHA: public tests>>=
   public :: blha_test
 <<BLHA: test driver>>=
   subroutine blha_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
     call test(blha_1, "blha_1", "Test the creation of BLHA-OLP files", u, results)
     call test(blha_2, "blha_2", "Test the creation of BLHA-OLP files for "&
          &"multiple flavor structures", u, results)
     call test(blha_3, "blha_3", "Test helicity-information in OpenLoops OLP files", &
          u, results)
   end subroutine blha_test
 
 @ %def blha_test
 @
 <<BLHA: test procedures>>=
   subroutine setup_and_write_blha_configuration (u, single, polarized)
     integer, intent(in) :: u
     logical, intent(in), optional :: single
     logical, intent(in), optional :: polarized
     logical :: polrzd, singl
     type(blha_master_t) :: blha_master
     integer :: i
     integer :: n_in, n_out
     integer :: alpha_power, alphas_power
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(string_t) :: proc_id, method, correction_type
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(var_list_t) :: var_list
     type(model_t), pointer :: model => null ()
     integer :: openloops_phs_tolerance
 
     polrzd = .false.; if (present (polarized)) polrzd = polarized
     singl = .true.; if (present (single)) singl = single
 
     if (singl) then
        write (u, "(A)") "* Process: e+ e- -> W+ W- b b~"
        n_in = 2; n_out = 4
        alpha_power = 4; alphas_power = 0
        allocate (flv_born (n_in + n_out, 1))
        allocate (flv_real (n_in + n_out + 1, 1))
        flv_born(1,1) = 11; flv_born(2,1) = -11
        flv_born(3,1) = 24; flv_born(4,1) = -24
        flv_born(5,1) = 5; flv_born(6,1) = -5
        flv_real(1:6,1) = flv_born(:,1)
        flv_real(7,1) = 21
     else
        write (u, "(A)") "* Process: e+ e- -> u:d:s U:D:S"
        n_in = 2; n_out = 2
        alpha_power = 2; alphas_power = 0
        allocate (flv_born (n_in + n_out, 3))
        allocate (flv_real (n_in + n_out + 1, 3))
        flv_born(1,:) = 11; flv_born(2,:) = -11
        flv_born(3,1) = 1; flv_born(4,1) = -1
        flv_born(3,2) = 2; flv_born(4,2) = -2
        flv_born(3,3) = 3; flv_born(4,3) = -3
        flv_real(1:4,:) = flv_born
        flv_real(5,:) = 21
     end if
     proc_id = var_str ("BLHA_Test")
 
     call syntax_model_file_init ()
     call os_data%init ()
     call model_list%read_model &
          (var_str ("SM"), var_str ("SM.mdl"), os_data, model)
 
     write (u, "(A)") "* BLHA matrix elements assumed for all process components"
     write (u, "(A)") "* Mode: GoSam"
 
     method = var_str ("gosam")
     correction_type = var_str ("QCD")
     call var_list%append_string (var_str ("$born_me_method"), method)
     call var_list%append_string (var_str ("$real_tree_me_method"), method)
     call var_list%append_string (var_str ("$loop_me_method"), method)
     call var_list%append_string (var_str ("$correlation_me_method"), method)
     call blha_master%set_ew_scheme (var_str ("GF"))
     call blha_master%set_methods (.true., var_list)
     call blha_master%allocate_config_files ()
     call blha_master%set_correction_type (correction_type)
     call blha_master%generate (proc_id, model, n_in, &
          alpha_power, alphas_power, flv_born, flv_real)
 
     call test_output (u)
 
     call blha_master%final ()
     call var_list%final ()
     write (u, "(A)") "* Switch to OpenLoops"
     openloops_phs_tolerance = 7
 
     method = var_str ("openloops")
     correction_type = var_str ("QCD")
     call var_list%append_string (var_str ("$born_me_method"), method)
     call var_list%append_string (var_str ("$real_tree_me_method"), method)
     call var_list%append_string (var_str ("$loop_me_method"), method)
     call var_list%append_string (var_str ("$correlation_me_method"), method)
     call blha_master%set_methods (.true., var_list)
     call blha_master%allocate_config_files ()
     call blha_master%set_correction_type (correction_type)
     call blha_master%generate (proc_id, model, n_in, &
          alpha_power, alphas_power, flv_born, flv_real)
 
     if (polrzd) then
        do i = 1, 4
           call blha_master%set_polarization (i)
        end do
     end if
     call blha_master%setup_additional_features &
          (openloops_phs_tolerance, .false., 0)
 
     call test_output (u)
 
   contains
 
     subroutine test_output (u)
       integer, intent(in) :: u
       do i = 1, 4
          call write_separator (u)
          call write_component_type (i, u)
          call write_separator (u)
          call blha_configuration_write &
               (blha_master%blha_cfg(i), u, no_version = .true.)
       end do
     end subroutine test_output
 
     subroutine write_component_type (i, u)
       integer, intent(in) :: i, u
       type(string_t) :: message, component_type
       message = var_str ("OLP-File content for ")
       select case (i)
       case (1)
          component_type = var_str ("loop")
       case (2)
          component_type = var_str ("subtraction")
       case (3)
          component_type = var_str ("real")
       case (4)
          component_type = var_str ("born")
       end select
       message = message // component_type // " matrix elements"
       write (u, "(A)") char (message)
     end subroutine write_component_type
 
   end subroutine setup_and_write_blha_configuration
 
 @ %def setup_and_write_blha_configuration
 @
 <<BLHA: test declarations>>=
   public :: blha_1
 <<BLHA: tests>>=
   subroutine blha_1 (u)
     integer, intent(in) :: u
     write (u, "(A)") "* Test output: blha_1"
     write (u, "(A)") "* Purpose: Test the creation of olp-files for single "&
          &"and unpolarized flavor structures"
     write (u, "(A)")
     call setup_and_write_blha_configuration (u, single = .true., polarized = .false.)
   end subroutine blha_1
 
 @ %def blha_1
 @
 <<BLHA: test declarations>>=
   public :: blha_2
 <<BLHA: tests>>=
   subroutine blha_2 (u)
     integer, intent(in) :: u
     write (u, "(A)") "* Test output: blha_2"
     write (u, "(A)") "* Purpose: Test the creation of olp-files for multiple "&
          &"and unpolarized flavor structures"
     write (u, "(A)")
     call setup_and_write_blha_configuration (u, single = .false., polarized = .false.)
   end subroutine blha_2
 
 @ %def blha_2
 @
 <<BLHA: test declarations>>=
   public :: blha_3
 <<BLHA: tests>>=
   subroutine blha_3 (u)
     integer, intent(in) :: u
     write (u, "(A)") "* Test output: blha_3"
     write (u, "(A)") "* Purpose: Test the creation of olp-files for single "&
          &"and polarized flavor structures"
     write (u, "(A)")
     call setup_and_write_blha_configuration (u, single = .true., polarized = .true.)
   end subroutine blha_3
 
 @ %def blha_3
 @
Index: trunk/src/variables/variables.nw
===================================================================
--- trunk/src/variables/variables.nw	(revision 8444)
+++ trunk/src/variables/variables.nw	(revision 8445)
@@ -1,6840 +1,6848 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: variables for processes
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Variables for Processes}
 \includemodulegraph{variables}
 
 This part introduces variables as user-controlled objects that
 influence the behavior of objects and calculations.  Variables contain
 objects of intrinsic type or of a type as introced above.
 \begin{description}
 \item[variables]
   Store values of various kind, used by expressions and accessed by
   the command interface.  This provides an implementation of the [[vars_t]]
   abstract type.
 \item[observables]
   Concrete implementation of observables (functions in the variable tree),
   applicable for \whizard.
   abstract type.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Variables: Implementation}
 The user interface deals with variables that are handled similarly to
 full-flegded programming languages.  The system will add a lot of
 predefined variables (model parameters, flags, etc.) that are
 accessible to the user by the same methods.
 
 Variables can be of various type: logical (boolean/flag), integer,
 real (default precision), subevents (used in cut expressions),
 arrays of PDG codes (aliases for particles), strings.  Furthermore, in
 cut expressions we have unary and binary observables, which are used
 like real parameters but behave like functions.
 <<[[variables.f90]]>>=
 <<File header>>
 
 module variables
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_utils, only: pac_fmt
   use format_defs, only: FMT_12, FMT_19
   use constants, only: eps0, tiny_07
   use os_interface, only: paths_t
   use physics_defs, only: LAMBDA_QCD_REF
   use system_dependencies
   use fastjet !NODEP!
   use diagnostics
   use pdg_arrays
   use subevents
 
   use var_base
 
 <<Standard module head>>
 
 <<Variables: public>>
 
 <<Variables: parameters>>
 
 <<Variables: types>>
 
 <<Variables: interfaces>>
 
 contains
 
 <<Variables: procedures>>
 
 end module variables
 @ %def variables
 @
 \subsection{Variable list entries}
 Variable (and constant) values can be of one of the following types:
 <<Variables: parameters>>=
   integer, parameter, public :: V_NONE = 0, V_LOG = 1, V_INT = 2, V_REAL = 3
   integer, parameter, public :: V_CMPLX = 4, V_SEV = 5, V_PDG = 6, V_STR = 7
   integer, parameter, public :: V_OBS1_INT = 11, V_OBS2_INT = 12
   integer, parameter, public :: V_OBS1_REAL = 21, V_OBS2_REAL = 22
   integer, parameter, public :: V_UOBS1_INT = 31, V_UOBS2_INT = 32
   integer, parameter, public :: V_UOBS1_REAL = 41, V_UOBS2_REAL = 42
 
 @ %def V_NONE V_LOG V_INT V_REAL V_CMPLX V_PRT V_SEV V_PDG
 @ %def V_OBS1_INT V_OBS2_INT V_OBS1_REAL V_OBS2_REAL
 @ %def V_UOBS1_INT V_UOBS2_INT V_UOBS1_REAL V_UOBS2_REAL
 @
 \subsubsection{The type}
 This is an entry in the variable list.  It can be of any type; in
 each case only one value is allocated.  It may be physically
 allocated upon creation, in which case [[is_allocated]] is true, or
 it may contain just a pointer to a value somewhere else, in which case
 [[is_allocated]] is false.
 
 The flag [[is_defined]] is set when the variable is given a value, even the
 undefined value.  (Therefore it is distinct from [[is_known]].)  This matters
 for variable declaration in the SINDARIN language.  The variable is set up in
 the compilation step and initially marked as defined, but after compilation
 all variables are set undefined.  Each variable becomes defined when it is
 explicitly set.  The difference matters in loops.
 
 [[is_locked]] means that it cannot be given a value using the interface
 routines [[var_list_set_XXX]] below.  It can only be initialized, or change
 automatically due to a side effect.
 
 [[is_copy]] means that this is a local copy of a global variable.  The copy
 has a pointer to the original, which can be used to restore a previous value.
 
 [[is_intrinsic]] means that this variable is defined by the program, not by
 the user.  Intrinsic variables cannot be (re)declared, but their values can be
 reset unless they are locked.  [[is_user_var]] means that the variable has
 been declared by the user.  It could be a new variable, or a local copy of an
 intrinsic variable.
 
 The flag [[is_known]] is a pointer which parallels the use of the
 value pointer.  For pointer variables, it is set if the value should point to
 a known value.  For ordinary variables, it should be true.
 
 The value is implemented as a set of alternative type-specific pointers.  This
 emulates polymorphism, and it allows for actual pointer variables.
 Observable-type variables have function pointers as values, so they behave
 like macros.  The functions make use of the particle objects accessible via
 the pointers [[prt1]] and [[prt2]].
 
 Finally, the [[next]] pointer indicates that we are making lists of
 variables.  A more efficient implementation might switch to hashes or
 similar; the current implementation has $O(N)$ lookup.
 <<Variables: public>>=
   public :: var_entry_t
 <<Variables: types>>=
   type :: var_entry_t
      private
      integer :: type = V_NONE
      type(string_t) :: name
      logical :: is_allocated = .false.
      logical :: is_defined = .false.
      logical :: is_locked = .false.
      logical :: is_intrinsic = .false.
      logical :: is_user_var = .false.
      logical, pointer :: is_known => null ()
      logical,           pointer :: lval => null ()
      integer,           pointer :: ival => null ()
      real(default),     pointer :: rval => null ()
      complex(default), pointer :: cval => null ()
      type(subevt_t),  pointer :: pval => null ()
      type(pdg_array_t), pointer :: aval => null ()
      type(string_t),    pointer :: sval => null ()
      procedure(obs_unary_int),   nopass, pointer :: obs1_int  => null ()
      procedure(obs_unary_real),  nopass, pointer :: obs1_real => null ()
      procedure(obs_binary_int),  nopass, pointer :: obs2_int  => null ()
      procedure(obs_binary_real), nopass, pointer :: obs2_real => null ()
      type(prt_t), pointer :: prt1 => null ()
      type(prt_t), pointer :: prt2 => null ()
      type(var_entry_t), pointer :: next => null ()
      type(var_entry_t), pointer :: previous => null ()
      type(string_t) :: description
   end type var_entry_t
 
 @ %def var_entry_t
 @
 \subsubsection{Interfaces for the observable functions}
 <<Variables: public>>=
   public :: obs_unary_int
   public :: obs_unary_real
   public :: obs_binary_int
   public :: obs_binary_real
 <<Variables: interfaces>>=
   abstract interface
      function obs_unary_int (prt1) result (ival)
        import
        integer :: ival
        type(prt_t), intent(in) :: prt1
      end function obs_unary_int
   end interface
   abstract interface
      function obs_unary_real (prt1) result (rval)
        import
        real(default) :: rval
        type(prt_t), intent(in) :: prt1
      end function obs_unary_real
   end interface
   abstract interface
      function obs_binary_int (prt1, prt2) result (ival)
        import
        integer :: ival
        type(prt_t), intent(in) :: prt1, prt2
      end function obs_binary_int
   end interface
   abstract interface
      function obs_binary_real (prt1, prt2) result (rval)
        import
        real(default) :: rval
        type(prt_t), intent(in) :: prt1, prt2
      end function obs_binary_real
   end interface
 
 @ %def obs_unary_int obs_unary_real obs_binary_real
 @
 \subsubsection{Initialization}
 Initialize an entry, optionally with a physical value.  We also
 allocate the [[is_known]] flag and set it if the value is set.
 <<Variables: public>>=
   public :: var_entry_init_int
 <<Variables: procedures>>=
   subroutine var_entry_init_log (var, name, lval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: lval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_LOG
     allocate (var%lval, var%is_known)
     if (present (lval)) then
        var%lval = lval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_log
 
   subroutine var_entry_init_int (var, name, ival, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: ival
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_INT
     allocate (var%ival, var%is_known)
     if (present (ival)) then
        var%ival = ival
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_int
 
   subroutine var_entry_init_real (var, name, rval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     real(default), intent(in), optional :: rval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_REAL
     allocate (var%rval, var%is_known)
     if (present (rval)) then
        var%rval = rval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_real
 
   subroutine var_entry_init_cmplx (var, name, cval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     complex(default), intent(in), optional :: cval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_CMPLX
     allocate (var%cval, var%is_known)
     if (present (cval)) then
        var%cval = cval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_cmplx
 
   subroutine var_entry_init_subevt (var, name, pval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), optional :: pval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_SEV
     allocate (var%pval, var%is_known)
     if (present (pval)) then
        var%pval = pval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_subevt
 
   subroutine var_entry_init_pdg_array (var, name, aval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), optional :: aval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_PDG
     allocate (var%aval, var%is_known)
     if (present (aval)) then
        var%aval = aval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_pdg_array
 
   subroutine var_entry_init_string (var, name, sval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: sval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_STR
     allocate (var%sval, var%is_known)
     if (present (sval)) then
        var%sval = sval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_string
 
 @ %def var_entry_init_log
 @ %def var_entry_init_int
 @ %def var_entry_init_real
 @ %def var_entry_init_cmplx
 @ %def var_entry_init_subevt
 @ %def var_entry_init_pdg_array
 @ %def var_entry_init_string
 @ Initialize an entry with a pointer to the value and, for numeric/logical
 values, a pointer to the [[is_known]] flag.
 <<Variables: procedures>>=
   subroutine var_entry_init_log_ptr (var, name, lval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     logical, intent(in), target :: lval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_LOG
     var%lval => lval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_log_ptr
 
   subroutine var_entry_init_int_ptr (var, name, ival, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     integer, intent(in), target :: ival
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_INT
     var%ival => ival
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_int_ptr
 
   subroutine var_entry_init_real_ptr (var, name, rval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     real(default), intent(in), target :: rval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_REAL
     var%rval => rval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_real_ptr
 
   subroutine var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     complex(default), intent(in), target :: cval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_CMPLX
     var%cval => cval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_cmplx_ptr
 
   subroutine var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), target :: aval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_PDG
     var%aval => aval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_pdg_array_ptr
 
   subroutine var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), target :: pval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_SEV
     var%pval => pval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_subevt_ptr
 
   subroutine var_entry_init_string_ptr (var, name, sval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(string_t), intent(in), target :: sval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_STR
     var%sval => sval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_string_ptr
 
 @ %def var_entry_init_log_ptr
 @ %def var_entry_init_int_ptr
 @ %def var_entry_init_real_ptr
 @ %def var_entry_init_cmplx_ptr
 @ %def var_entry_init_pdg_array_ptr
 @ %def var_entry_init_subevt_ptr
 @ %def var_entry_init_string_ptr
 @ Initialize an entry with an observable.  The procedure pointer is
 not yet set.
 <<Variables: procedures>>=
   subroutine var_entry_init_obs (var, name, type, prt1, prt2)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     integer, intent(in) :: type
     type(prt_t), intent(in), target :: prt1
     type(prt_t), intent(in), optional, target :: prt2
     var%type = type
     var%name = name
     var%prt1 => prt1
     if (present (prt2))  var%prt2 => prt2
     var%is_intrinsic = .true.
     var%is_defined = .true.
   end subroutine var_entry_init_obs
 
 @ %def var_entry_init_obs
 @ Mark an entry as undefined it it is a user-defined variable object, so force
 re-initialization.
 <<Variables: procedures>>=
   subroutine var_entry_undefine (var)
     type(var_entry_t), intent(inout) :: var
     var%is_defined = .not. var%is_user_var
     var%is_known = var%is_defined .and. var%is_known
   end subroutine var_entry_undefine
 
 @ %def var_entry_undefine
 @ Clear an entry: mark it as unknown.
 <<Variables: procedures>>=
   subroutine var_entry_clear (var)
     type(var_entry_t), intent(inout) :: var
     var%is_known = .false.
   end subroutine var_entry_clear
 
 @ %def var_entry_clear
 @ Lock an entry: forbid resetting the entry after initialization.
 <<Variables: procedures>>=
   subroutine var_entry_lock (var, locked)
     type(var_entry_t), intent(inout) :: var
     logical, intent(in), optional :: locked
     if (present (locked)) then
        var%is_locked = locked
     else
        var%is_locked = .true.
     end if
   end subroutine var_entry_lock
 
 @ %def var_entry_lock
 @
 \subsubsection{Finalizer}
 <<Variables: procedures>>=
   subroutine var_entry_final (var)
     type(var_entry_t), intent(inout) :: var
     if (var%is_allocated) then
        select case (var%type)
        case (V_LOG); deallocate (var%lval)
        case (V_INT); deallocate (var%ival)
        case (V_REAL);deallocate (var%rval)
        case (V_CMPLX);deallocate (var%cval)
        case (V_SEV); deallocate (var%pval)
        case (V_PDG); deallocate (var%aval)
        case (V_STR); deallocate (var%sval)
        end select
        deallocate (var%is_known)
        var%is_allocated = .false.
        var%is_defined = .false.
     end if
   end subroutine var_entry_final
 
 @ %def var_entry_final
 @
 \subsubsection{Output}
 <<Variables: procedures>>=
   recursive subroutine var_entry_write (var, unit, model_name, &
        intrinsic, pacified, descriptions, ascii_output)
     type(var_entry_t), intent(in) :: var
     integer, intent(in), optional :: unit
     type(string_t), intent(in), optional :: model_name
     logical, intent(in), optional :: intrinsic
     logical, intent(in), optional :: pacified
     logical, intent(in), optional :: descriptions
     logical, intent(in), optional :: ascii_output
     type(string_t) :: col_string
     logical :: show_desc, ao
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     show_desc = .false.; if (present (descriptions))  show_desc = descriptions
     ao = .false.; if (present (ascii_output))  ao = ascii_output
     if (show_desc) then
        if (ao) then
           col_string = create_col_string (COL_BLUE)
           if (var%is_locked) then
              write (u, "(A)", advance="no") char (achar(27) // col_string) // &
                   char (var%name) // achar(27) // "[0m" //" fixed-value="
           else
              write (u, "(A)", advance="no") char (achar(27) // col_string) // &
                   char (var%name) // achar(27) // "[0m" //" default="
           end if
           col_string = create_col_string (COL_RED)
           write (u, "(A)", advance="no") char (achar(27) // col_string)
           call var_write_val (var, u, "no", pacified=.true.)
           write (u, "(A)") achar(27) // "[0m"
           write (u, "(A)")  char (var%description)
           return
        else
           write (u, "(A)")  "\item"
           write (u, "(A)", advance="no")  "\ttt{" // char ( &
                replace (replace (var%name, "_", "\_", every=.true.), "$", "\$" )) // &
                "} "
           if (var%is_known) then
              if (var%is_locked) then
                 write (u, "(A)", advance="no")  "\qquad (fixed value: \ttt{"
              else
                 write (u, "(A)", advance="no")  "\qquad (default: \ttt{"
              end if
              call var_write_val (var, u, "no", pacified=.true., escape_tex=.true.)
              write (u, "(A)", advance="no")  "})"
           end if
           write (u, "(A)") " \newline"
           write (u, "(A)") char (var%description)
           write (u, "(A)") "%%%%%"
           return
        end if
     end if
     if (present (intrinsic)) then
        if (var%is_intrinsic .neqv. intrinsic)  return
     end if
     if (.not. var%is_defined) then
        write (u, "(A,1x)", advance="no")  "[undefined]"
     end if
     if (.not. var%is_intrinsic) then
        write (u, "(A,1x)", advance="no")  "[user variable]"
     end if
     if (present (model_name)) then
        write (u, "(A,A)", advance="no")  char(model_name), "."
     end if
     write (u, "(A)", advance="no")  char (var%name)
     if (var%is_locked)  write (u, "(A)", advance="no")  "*"
     if (var%is_allocated) then
        write (u, "(A)", advance="no")  " = "
     else if (var%type /= V_NONE) then
        write (u, "(A)", advance="no")  " => "
     end if
     call var_write_val (var, u, "yes", pacified)
   end subroutine var_entry_write
 
 @ %def var_entry_write
 @
 <<Variables: procedures>>=
   subroutine var_write_val (var, u, advance, pacified, escape_tex)
     type(var_entry_t), intent(in) :: var
     integer, intent(in) :: u
     character(*), intent(in) :: advance
     logical, intent(in), optional :: pacified, escape_tex
     logical :: num_pac, et
     real(default) :: rval
     complex(default) :: cval
     character(len=7) :: fmt
     call pac_fmt (fmt, FMT_19, FMT_12, pacified)
     num_pac = .false.; if (present (pacified))  num_pac = pacified
     et = .false.; if (present (escape_tex))  et = escape_tex
     select case (var%type)
     case (V_NONE); write (u, '()', advance=advance)
     case (V_LOG)
        if (var%is_known) then
           if (var%lval) then
              write (u, "(A)", advance=advance)  "true"
           else
              write (u, "(A)", advance=advance)  "false"
           end if
        else
           write (u, "(A)", advance=advance)  "[unknown logical]"
        end if
     case (V_INT)
        if (var%is_known) then
           write (u, "(I0)", advance=advance)  var%ival
        else
           write (u, "(A)", advance=advance)  "[unknown integer]"
        end if
     case (V_REAL)
        if (var%is_known) then
           rval = var%rval
           if (num_pac) then
              call pacify (rval, 10 * eps0)
           end if
           write (u, "(" // fmt // ")", advance=advance)  rval
        else
           write (u, "(A)", advance=advance)  "[unknown real]"
        end if
     case (V_CMPLX)
        if (var%is_known) then
           cval = var%cval
           if (num_pac) then
              call pacify (cval, 10 * eps0)
           end if
           write (u, "('('," // fmt // ",','," // fmt // ",')')", advance=advance)  cval
        else
           write (u, "(A)", advance=advance)  "[unknown complex]"
        end if
     case (V_SEV)
        if (var%is_known) then
           call subevt_write (var%pval, u, prefix="       ", &
                pacified = pacified)
        else
           write (u, "(A)", advance=advance)  "[unknown subevent]"
        end if
     case (V_PDG)
        if (var%is_known) then
           call pdg_array_write (var%aval, u);  write (u, *)
        else
           write (u, "(A)", advance=advance)  "[unknown PDG array]"
        end if
     case (V_STR)
        if (var%is_known) then
           if (et) then
              write (u, "(A)", advance=advance)  '"' // char (replace ( &
                   replace (var%sval, "_", "\_", every=.true.), "$", "\$" )) // '"'
           else
              write (u, "(A)", advance=advance)  '"' // char (var%sval) // '"'
           end if
        else
           write (u, "(A)", advance=advance)  "[unknown string]"
        end if
     case (V_OBS1_INT);  write (u, "(A)", advance=advance) "[int] = unary observable"
     case (V_OBS2_INT);  write (u, "(A)", advance=advance) "[int] = binary observable"
     case (V_OBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary observable"
     case (V_OBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary observable"
     case (V_UOBS1_INT);  write (u, "(A)", advance=advance) "[int] = unary user observable"
     case (V_UOBS2_INT);  write (u, "(A)", advance=advance) "[int] = binary user observable"
     case (V_UOBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary user observable"
     case (V_UOBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary user observable"
     end select
   end subroutine var_write_val
 
 @ %def procedure
 @
 \subsubsection{Accessing contents}
 <<Variables: procedures>>=
   function var_entry_get_name (var) result (name)
     type(string_t) :: name
     type(var_entry_t), intent(in) :: var
     name = var%name
   end function var_entry_get_name
 
   function var_entry_get_type (var) result (type)
     integer :: type
     type(var_entry_t), intent(in) :: var
     type = var%type
   end function var_entry_get_type
 
 @ %def var_entry_get_name var_entry_get_type
 @ Return true if the variable is defined.  This the case if it is allocated
 and known, or if it is a pointer.
 <<Variables: procedures>>=
   function var_entry_is_defined (var) result (defined)
     logical :: defined
     type(var_entry_t), intent(in) :: var
     defined = var%is_defined
   end function var_entry_is_defined
 
 @ %def var_entry_is_defined
 @ Return true if the variable is locked.  If [[force]] is active,
 always return false.
 <<Variables: procedures>>=
   function var_entry_is_locked (var, force) result (locked)
     logical :: locked
     type(var_entry_t), intent(in) :: var
     logical, intent(in), optional :: force
     if (present (force)) then
        if (force) then
           locked = .false.;  return
        end if
     end if
     locked = var%is_locked
   end function var_entry_is_locked
 
 @ %def var_entry_is_locked
 @ Return true if the variable is intrinsic
 <<Variables: procedures>>=
   function var_entry_is_intrinsic (var) result (flag)
     logical :: flag
     type(var_entry_t), intent(in) :: var
     flag = var%is_intrinsic
   end function var_entry_is_intrinsic
 
 @ %def var_entry_is_intrinsic
 @ Return components
 <<Variables: procedures>>=
   function var_entry_is_known (var) result (flag)
     logical :: flag
     type(var_entry_t), intent(in) :: var
     flag = var%is_known
   end function var_entry_is_known
 
   function var_entry_get_lval (var) result (lval)
     logical :: lval
     type(var_entry_t), intent(in) :: var
     lval = var%lval
   end function var_entry_get_lval
 
   function var_entry_get_ival (var) result (ival)
     integer :: ival
     type(var_entry_t), intent(in) :: var
     ival = var%ival
   end function var_entry_get_ival
 
   function var_entry_get_rval (var) result (rval)
     real(default) :: rval
     type(var_entry_t), intent(in) :: var
     rval = var%rval
   end function var_entry_get_rval
 
   function var_entry_get_cval (var) result (cval)
     complex(default) :: cval
     type(var_entry_t), intent(in) :: var
     cval = var%cval
   end function var_entry_get_cval
 
   function var_entry_get_aval (var) result (aval)
     type(pdg_array_t) :: aval
     type(var_entry_t), intent(in) :: var
     aval = var%aval
   end function var_entry_get_aval
 
   function var_entry_get_pval (var) result (pval)
     type(subevt_t) :: pval
     type(var_entry_t), intent(in) :: var
     pval = var%pval
   end function var_entry_get_pval
 
   function var_entry_get_sval (var) result (sval)
     type(string_t) :: sval
     type(var_entry_t), intent(in) :: var
     sval = var%sval
   end function var_entry_get_sval
 
 @ %def var_entry_get_lval
 @ %def var_entry_get_ival
 @ %def var_entry_get_rval
 @ %def var_entry_get_cval
 @ %def var_entry_get_aval
 @ %def var_entry_get_pval
 @ %def var_entry_get_sval
 @ Return pointers to components.
 <<Variables: procedures>>=
   function var_entry_get_known_ptr (var) result (ptr)
     logical, pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%is_known
   end function var_entry_get_known_ptr
 
   function var_entry_get_lval_ptr (var) result (ptr)
     logical, pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%lval
   end function var_entry_get_lval_ptr
 
   function var_entry_get_ival_ptr (var) result (ptr)
     integer, pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%ival
   end function var_entry_get_ival_ptr
 
   function var_entry_get_rval_ptr (var) result (ptr)
     real(default), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%rval
   end function var_entry_get_rval_ptr
 
   function var_entry_get_cval_ptr (var) result (ptr)
     complex(default), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%cval
   end function var_entry_get_cval_ptr
 
   function var_entry_get_pval_ptr (var) result (ptr)
     type(subevt_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%pval
   end function var_entry_get_pval_ptr
 
   function var_entry_get_aval_ptr (var) result (ptr)
     type(pdg_array_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%aval
   end function var_entry_get_aval_ptr
 
   function var_entry_get_sval_ptr (var) result (ptr)
     type(string_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%sval
   end function var_entry_get_sval_ptr
 
 @ %def var_entry_get_known_ptr
 @ %def var_entry_get_lval_ptr var_entry_get_ival_ptr var_entry_get_rval_ptr
 @ %def var_entry_get_cval_ptr var_entry_get_aval_ptr var_entry_get_pval_ptr
 @ %def var_entry_get_sval_ptr
 @ Furthermore,
 <<Variables: procedures>>=
   function var_entry_get_prt1_ptr (var) result (ptr)
     type(prt_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%prt1
   end function var_entry_get_prt1_ptr
 
   function var_entry_get_prt2_ptr (var) result (ptr)
     type(prt_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%prt2
   end function var_entry_get_prt2_ptr
 
 @ %def var_entry_get_prt1_ptr
 @ %def var_entry_get_prt2_ptr
 @ Subroutines might be safer than functions for procedure pointer transfer.
 <<Variables: procedures>>=
   subroutine var_entry_assign_obs1_int_ptr (ptr, var)
     procedure(obs_unary_int), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obs1_int
   end subroutine var_entry_assign_obs1_int_ptr
 
   subroutine var_entry_assign_obs1_real_ptr (ptr, var)
     procedure(obs_unary_real), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obs1_real
   end subroutine var_entry_assign_obs1_real_ptr
 
   subroutine var_entry_assign_obs2_int_ptr (ptr, var)
     procedure(obs_binary_int), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obs2_int
   end subroutine var_entry_assign_obs2_int_ptr
 
   subroutine var_entry_assign_obs2_real_ptr (ptr, var)
     procedure(obs_binary_real), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obs2_real
   end subroutine var_entry_assign_obs2_real_ptr
 
 @ %def var_entry_assign_obs1_int_ptr var_entry_assign_obs1_real_ptr
 @ %def var_entry_assign_obs2_int_ptr var_entry_assign_obs2_real_ptr
 @
 \subsection{Setting values}
 Undefine the value.
 <<Variables: procedures>>=
   subroutine var_entry_clear_value (var)
     type(var_entry_t), intent(inout) :: var
     var%is_known = .false.
   end subroutine var_entry_clear_value
 
 @ %def var_entry_clear_value
 <<Variables: procedures>>=
   recursive subroutine var_entry_set_log &
        (var, lval, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     logical, intent(in) :: lval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%lval = lval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_log
 
   recursive subroutine var_entry_set_int &
        (var, ival, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     integer, intent(in) :: ival
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%ival = ival
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_int
 
   recursive subroutine var_entry_set_real &
        (var, rval, is_known, verbose, model_name, pacified)
     type(var_entry_t), intent(inout) :: var
     real(default), intent(in) :: rval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose, pacified
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%rval = rval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write &
                (var, model_name=model_name, pacified = pacified)
           call var_entry_write &
                (var, model_name=model_name, unit=u, pacified = pacified)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_real
 
   recursive subroutine var_entry_set_cmplx &
        (var, cval, is_known, verbose, model_name, pacified)
     type(var_entry_t), intent(inout) :: var
     complex(default), intent(in) :: cval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose, pacified
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%cval = cval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write &
                (var, model_name=model_name, pacified = pacified)
           call var_entry_write &
                (var, model_name=model_name, unit=u, pacified = pacified)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_cmplx
 
   recursive subroutine var_entry_set_pdg_array &
        (var, aval, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     type(pdg_array_t), intent(in) :: aval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%aval = aval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_pdg_array
 
   recursive subroutine var_entry_set_subevt &
        (var, pval, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     type(subevt_t), intent(in) :: pval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%pval = pval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_subevt
 
   recursive subroutine var_entry_set_string &
        (var, sval, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     type(string_t), intent(in) :: sval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%sval = sval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_string
 
 @ %def var_entry_set_log
 @ %def var_entry_set_int
 @ %def var_entry_set_real
 @ %def var_entry_set_cmplx
 @ %def var_entry_set_pdg_array
 @ %def var_entry_set_subevt
 @ %def var_entry_set_string
 @
 <<Variables: public>>=
   public :: var_entry_set_description
 <<Variables: procedures>>=
   pure subroutine var_entry_set_description (var_entry, description)
     type(var_entry_t), intent(inout) :: var_entry
     type(string_t), intent(in) :: description
     var_entry%description = description
   end subroutine var_entry_set_description
 
 @ %def var_entry_set_description
 @
 \subsection{Copies and pointer variables}
 Initialize an entry with a copy of an existing variable entry.  The
 copy is physically allocated with the same type as the original.
 <<Variables: procedures>>=
   subroutine var_entry_init_copy (var, original, user)
     type(var_entry_t), intent(out) :: var
     type(var_entry_t), intent(in), target :: original
     logical, intent(in), optional :: user
     type(string_t) :: name
     logical :: intrinsic
     name = var_entry_get_name (original)
     intrinsic = original%is_intrinsic
     select case (original%type)
     case (V_LOG)
        call var_entry_init_log (var, name, intrinsic=intrinsic, user=user)
     case (V_INT)
        call var_entry_init_int (var, name, intrinsic=intrinsic, user=user)
     case (V_REAL)
        call var_entry_init_real (var, name, intrinsic=intrinsic, user=user)
     case (V_CMPLX)
        call var_entry_init_cmplx (var, name, intrinsic=intrinsic, user=user)
     case (V_SEV)
        call var_entry_init_subevt (var, name, intrinsic=intrinsic, user=user)
     case (V_PDG)
        call var_entry_init_pdg_array (var, name, intrinsic=intrinsic, user=user)
     case (V_STR)
        call var_entry_init_string (var, name, intrinsic=intrinsic, user=user)
     end select
   end subroutine var_entry_init_copy
 
 @ %def var_entry_init_copy
 @ Copy the value of an entry.  The target variable entry must be initialized
 correctly.
 <<Variables: procedures>>=
   subroutine var_entry_copy_value (var, original)
     type(var_entry_t), intent(inout) :: var
     type(var_entry_t), intent(in), target :: original
     if (var_entry_is_known (original)) then
        select case (original%type)
        case (V_LOG)
           call var_entry_set_log (var, var_entry_get_lval (original), .true.)
        case (V_INT)
           call var_entry_set_int (var, var_entry_get_ival (original), .true.)
        case (V_REAL)
           call var_entry_set_real (var, var_entry_get_rval (original), .true.)
        case (V_CMPLX)
           call var_entry_set_cmplx (var, var_entry_get_cval (original), .true.)
        case (V_SEV)
           call var_entry_set_subevt (var, var_entry_get_pval (original), .true.)
        case (V_PDG)
           call var_entry_set_pdg_array (var, var_entry_get_aval (original), .true.)
        case (V_STR)
           call var_entry_set_string (var, var_entry_get_sval (original), .true.)
        end select
     else
        call var_entry_clear (var)
     end if
   end subroutine var_entry_copy_value
 
 @ %def var_entry_copy_value
 @
 \subsection{Variable lists}
 \subsubsection{The type}
 Variable lists can be linked together.  No initializer needed.
 They are deleted separately.
 <<Variables: public>>=
   public :: var_list_t
 <<Variables: types>>=
   type, extends (vars_t) :: var_list_t
      private
      type(var_entry_t), pointer :: first => null ()
      type(var_entry_t), pointer :: last => null ()
      type(var_list_t), pointer :: next => null ()
    contains
    <<Variables: var list: TBP>>
   end type var_list_t
 
 @ %def var_list_t
 @
 \subsubsection{Constructors}
 Implementation of the [[link]] deferred method.  The implementation
 restricts itself to var lists of the same type.  We might need to
 relax this constraint.
 <<Variables: var list: TBP>>=
   procedure :: link => var_list_link
 <<Variables: procedures>>=
   subroutine var_list_link (vars, target_vars)
     class(var_list_t), intent(inout) :: vars
     class(vars_t), intent(in), target :: target_vars
     select type (target_vars)
     type is (var_list_t)
        vars%next => target_vars
     class default
        call msg_bug ("var_list_link: unsupported target type")
     end select
   end subroutine var_list_link
 
 @ %def var_list_link
 @ Append a new entry to an existing list.
 <<Variables: procedures>>=
   subroutine var_list_append (var_list, var, verbose)
     type(var_list_t), intent(inout), target :: var_list
     type(var_entry_t), intent(inout), target :: var
     logical, intent(in), optional :: verbose
     if (associated (var_list%last)) then
        var%previous => var_list%last
        var_list%last%next => var
     else
        var%previous => null ()
        var_list%first => var
     end if
     var_list%last => var
     if (present (verbose)) then
        if (verbose)  call var_entry_write (var)
     end if
   end subroutine var_list_append
 
 @ %def var_list_append
 @ Sort a list.
 <<Variables: var list: TBP>>=
   procedure :: sort => var_list_sort
 <<Variables: procedures>>=
   subroutine var_list_sort (var_list)
     class(var_list_t), intent(inout) :: var_list
     type(var_entry_t), pointer :: var, previous
     if (associated (var_list%first)) then
        var => var_list%first
        do while (associated (var))
           previous => var%previous
           do while (associated (previous))
              if (larger_var (previous, var)) then
                 call var_list%swap_with_next (previous)
              end if
              previous => previous%previous
           end do
           var => var%next
        end do
     end if
   end subroutine var_list_sort
 
 @ %def var_list_sort
 @
 <<Variables: procedures>>=
   pure function larger_var (var1, var2) result (larger)
     logical :: larger
     type(var_entry_t), intent(in) :: var1, var2
     type(string_t) :: str1, str2
     str1 = replace (var1%name, "?", "")
     str1 = replace (str1, "$", "")
     str2 = replace (var2%name, "?", "")
     str2 = replace (str2, "$", "")
     larger = str1 > str2
   end function larger_var
 
 @ %def larger_var
 @
 <<Variables: var list: TBP>>=
   procedure :: get_previous => var_list_get_previous
 <<Variables: procedures>>=
   function var_list_get_previous (var_list, var_entry) result (previous)
     type(var_entry_t), pointer :: previous
     class(var_list_t), intent(in) :: var_list
     type(var_entry_t), intent(in) :: var_entry
     previous => var_list%first
     if (previous%name == var_entry%name) then
        previous => null ()
     else
        do while (associated (previous))
           if (previous%next%name == var_entry%name) exit
           previous => previous%next
        end do
     end if
   end function var_list_get_previous
 
 @ %def var_list_get_previous
 @
 <<Variables: var list: TBP>>=
   procedure :: swap_with_next => var_list_swap_with_next
 <<Variables: procedures>>=
   subroutine var_list_swap_with_next (var_list, var_entry)
     class(var_list_t), intent(inout) :: var_list
     type(var_entry_t), intent(in) :: var_entry
     type(var_entry_t), pointer :: previous, this, next, next_next
     previous => var_list%get_previous (var_entry)
     if (.not. associated (previous)) then
        this => var_list%first
     else
        this => previous%next
     end if
     next => this%next
     next_next => next%next
     if (associated (previous)) then
        previous%next => next
        next%previous => previous
     else
        var_list%first => next
        next%previous => null ()
     end if
     this%next => next_next
     if (associated (next_next)) then
        next_next%previous => this
     end if
     next%next => this
     this%previous => next
     if (.not. associated (next%next)) then
        var_list%last => next
     end if
   end subroutine var_list_swap_with_next
 
 @ %def var_list_swap_with_next
 @ Public methods for expanding the variable list (as subroutines)
 <<Variables: var list: TBP>>=
   generic :: append_log => var_list_append_log_s, var_list_append_log_c
   procedure, private :: var_list_append_log_s
   procedure, private :: var_list_append_log_c
   generic :: append_int => var_list_append_int_s, var_list_append_int_c
   procedure, private :: var_list_append_int_s
   procedure, private :: var_list_append_int_c
   generic :: append_real => var_list_append_real_s, var_list_append_real_c
   procedure, private :: var_list_append_real_s
   procedure, private :: var_list_append_real_c
   generic :: append_cmplx => var_list_append_cmplx_s, var_list_append_cmplx_c
   procedure, private :: var_list_append_cmplx_s
   procedure, private :: var_list_append_cmplx_c
   generic :: append_subevt => var_list_append_subevt_s, var_list_append_subevt_c
   procedure, private :: var_list_append_subevt_s
   procedure, private :: var_list_append_subevt_c
   generic :: append_pdg_array => var_list_append_pdg_array_s, var_list_append_pdg_array_c
   procedure, private :: var_list_append_pdg_array_s
   procedure, private :: var_list_append_pdg_array_c
   generic :: append_string => var_list_append_string_s, var_list_append_string_c
   procedure, private :: var_list_append_string_s
   procedure, private :: var_list_append_string_c
 <<Variables: public>>=
   public :: var_list_append_log
   public :: var_list_append_int
   public :: var_list_append_real
   public :: var_list_append_cmplx
   public :: var_list_append_subevt
   public :: var_list_append_pdg_array
   public :: var_list_append_string
 <<Variables: interfaces>>=
   interface var_list_append_log
      module procedure var_list_append_log_s
      module procedure var_list_append_log_c
   end interface
   interface var_list_append_int
      module procedure var_list_append_int_s
      module procedure var_list_append_int_c
   end interface
   interface var_list_append_real
      module procedure var_list_append_real_s
      module procedure var_list_append_real_c
   end interface
   interface var_list_append_cmplx
      module procedure var_list_append_cmplx_s
      module procedure var_list_append_cmplx_c
   end interface
   interface var_list_append_subevt
      module procedure var_list_append_subevt_s
      module procedure var_list_append_subevt_c
   end interface
   interface var_list_append_pdg_array
      module procedure var_list_append_pdg_array_s
      module procedure var_list_append_pdg_array_c
   end interface
   interface var_list_append_string
      module procedure var_list_append_string_s
      module procedure var_list_append_string_c
   end interface
 <<Variables: procedures>>=
   subroutine var_list_append_log_s &
        (var_list, name, lval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: lval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_log (var, name, lval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_log_s
 
   subroutine var_list_append_int_s &
        (var_list, name, ival, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: ival
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_int (var, name, ival, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_int_s
 
   subroutine var_list_append_real_s &
        (var_list, name, rval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     real(default), intent(in), optional :: rval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_real (var, name, rval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_real_s
 
   subroutine var_list_append_cmplx_s &
        (var_list, name, cval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     complex(default), intent(in), optional :: cval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_cmplx (var, name, cval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_cmplx_s
 
   subroutine var_list_append_subevt_s &
        (var_list, name, pval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), optional :: pval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_subevt (var, name, pval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_subevt_s
 
   subroutine var_list_append_pdg_array_s &
        (var_list, name, aval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), optional :: aval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_pdg_array (var, name, aval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_pdg_array_s
 
   subroutine var_list_append_string_s &
        (var_list, name, sval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: sval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_string (var, name, sval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_string_s
 
   subroutine var_list_append_log_c &
        (var_list, name, lval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     logical, intent(in), optional :: lval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_log_s &
          (var_list, var_str (name), lval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_log_c
 
   subroutine var_list_append_int_c &
        (var_list, name, ival, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     integer, intent(in), optional :: ival
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_int_s &
          (var_list, var_str (name), ival, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_int_c
 
   subroutine var_list_append_real_c &
        (var_list, name, rval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     real(default), intent(in), optional :: rval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_real_s &
          (var_list, var_str (name), rval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_real_c
 
   subroutine var_list_append_cmplx_c &
        (var_list, name, cval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     complex(default), intent(in), optional :: cval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_cmplx_s &
          (var_list, var_str (name), cval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_cmplx_c
 
   subroutine var_list_append_subevt_c &
        (var_list, name, pval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     type(subevt_t), intent(in), optional :: pval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_subevt_s &
          (var_list, var_str (name), pval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_subevt_c
 
   subroutine var_list_append_pdg_array_c &
        (var_list, name, aval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     type(pdg_array_t), intent(in), optional :: aval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_pdg_array_s &
          (var_list, var_str (name), aval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_pdg_array_c
 
   subroutine var_list_append_string_c &
        (var_list, name, sval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     character(*), intent(in), optional :: sval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     if (present (sval)) then
        call var_list_append_string_s &
             (var_list, var_str (name), var_str (sval), &
             locked, verbose, intrinsic, user, description)
     else
        call var_list_append_string_s &
             (var_list, var_str (name), &
             locked=locked, verbose=verbose, intrinsic=intrinsic, &
             user=user, description=description)
     end if
   end subroutine var_list_append_string_c
 
 @ %def var_list_append_log
 @ %def var_list_append_int
 @ %def var_list_append_real
 @ %def var_list_append_cmplx
 @ %def var_list_append_subevt
 @ %def var_list_append_pdg_array
 @ %def var_list_append_string
 <<Variables: public>>=
   public :: var_list_append_log_ptr
   public :: var_list_append_int_ptr
   public :: var_list_append_real_ptr
   public :: var_list_append_cmplx_ptr
   public :: var_list_append_pdg_array_ptr
   public :: var_list_append_subevt_ptr
   public :: var_list_append_string_ptr
 <<Variables: var list: TBP>>=
   procedure :: append_log_ptr => var_list_append_log_ptr
   procedure :: append_int_ptr => var_list_append_int_ptr
   procedure :: append_real_ptr => var_list_append_real_ptr
   procedure :: append_cmplx_ptr => var_list_append_cmplx_ptr
   procedure :: append_pdg_array_ptr => var_list_append_pdg_array_ptr
   procedure :: append_subevt_ptr => var_list_append_subevt_ptr
   procedure :: append_string_ptr => var_list_append_string_ptr
 <<Variables: procedures>>=
   subroutine var_list_append_log_ptr &
        (var_list, name, lval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     logical, intent(in), target :: lval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_log_ptr (var, name, lval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_log_ptr
 
   subroutine var_list_append_int_ptr &
        (var_list, name, ival, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in), target :: ival
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_int_ptr (var, name, ival, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_int_ptr
 
   subroutine var_list_append_real_ptr &
        (var_list, name, rval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     real(default), intent(in), target :: rval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_real_ptr (var, name, rval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_real_ptr
 
   subroutine var_list_append_cmplx_ptr &
        (var_list, name, cval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     complex(default), intent(in), target :: cval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_cmplx_ptr
 
   subroutine var_list_append_pdg_array_ptr &
        (var_list, name, aval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), target :: aval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_pdg_array_ptr
 
   subroutine var_list_append_subevt_ptr &
        (var_list, name, pval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), target :: pval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_subevt_ptr
 
   subroutine var_list_append_string_ptr &
        (var_list, name, sval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(string_t), intent(in), target :: sval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_string_ptr (var, name, sval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_string_ptr
 
 @ %def var_list_append_log_ptr
 @ %def var_list_append_int_ptr
 @ %def var_list_append_real_ptr
 @ %def var_list_append_cmplx_ptr
 @ %def var_list_append_pdg_array_ptr
 @ %def var_list_append_subevt_ptr
 @
 \subsubsection{Finalizer}
 Finalize, delete the list entry by entry.  The link itself is kept
 intact.  Follow link and delete recursively only if requested
 explicitly.
 <<Variables: var list: TBP>>=
   procedure :: final => var_list_final
 <<Variables: procedures>>=
   recursive subroutine var_list_final (vars, follow_link)
     class(var_list_t), intent(inout) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     vars%last => null ()
     do while (associated (vars%first))
        var => vars%first
        vars%first => var%next
        call var_entry_final (var)
        deallocate (var)
     end do
     if (present (follow_link)) then
        if (follow_link) then
           if (associated (vars%next)) then
              call vars%next%final (follow_link)
              deallocate (vars%next)
           end if
        end if
     end if
   end subroutine var_list_final
 
 @ %def var_list_final
 @
 \subsubsection{Output}
 Show variable list with precise control over options.  E.g.,
 show only variables of a certain type.
 
 Many options, thus not an ordinary [[write]] method.
 <<Variables: public>>=
   public :: var_list_write
 <<Variables: var list: TBP>>=
   procedure :: write => var_list_write
 <<Variables: procedures>>=
   recursive subroutine var_list_write &
        (var_list, unit, follow_link, only_type, prefix, model_name, &
         intrinsic, pacified, descriptions, ascii_output)
     class(var_list_t), intent(in), target :: var_list
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: follow_link
     integer, intent(in), optional :: only_type
     character(*), intent(in), optional :: prefix
     type(string_t), intent(in), optional :: model_name
     logical, intent(in), optional :: intrinsic
     logical, intent(in), optional :: pacified
     logical, intent(in), optional :: descriptions
     logical, intent(in), optional :: ascii_output
     type(var_entry_t), pointer :: var
     integer :: u, length
     logical :: write_this, write_next
     u = given_output_unit (unit);  if (u < 0)  return
     if (present (prefix))  length = len (prefix)
     var => var_list%first
     if (associated (var)) then
        do while (associated (var))
           if (present (only_type)) then
              write_this = only_type == var%type
           else
              write_this = .true.
           end if
           if (write_this .and. present (prefix)) then
              if (prefix /= extract (var%name, 1, length)) &
                   write_this = .false.
           end if
           if (write_this) then
              call var_entry_write &
                   (var, unit, model_name=model_name, &
                    intrinsic=intrinsic, pacified=pacified, &
                    descriptions=descriptions, ascii_output=ascii_output)
           end if
           var => var%next
        end do
     end if
     if (present (follow_link)) then
        write_next = follow_link .and. associated (var_list%next)
     else
        write_next = associated (var_list%next)
     end if
     if (write_next) then
        call var_list_write (var_list%next, &
             unit, follow_link, only_type, prefix, model_name, &
             intrinsic, pacified)
     end if
   end subroutine var_list_write
 
 @ %def var_list_write
 @ Write only a certain variable.
 <<Variables: public>>=
   public :: var_list_write_var
 <<Variables: var list: TBP>>=
   procedure :: write_var => var_list_write_var
 <<Variables: procedures>>=
   recursive subroutine var_list_write_var &
        (var_list, name, unit, type, follow_link, &
        model_name, pacified, defined, descriptions, ascii_output)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: type
     logical, intent(in), optional :: follow_link
     type(string_t), intent(in), optional :: model_name
     logical, intent(in), optional :: pacified
     logical, intent(in), optional :: defined
     logical, intent(in), optional :: descriptions
     logical, intent(in), optional :: ascii_output
     type(var_entry_t), pointer :: var
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     var => var_list_get_var_ptr &
          (var_list, name, type, follow_link=follow_link, defined=defined)
     if (associated (var)) then
        call var_entry_write &
             (var, unit, model_name = model_name, &
             pacified = pacified, &
             descriptions=descriptions, ascii_output=ascii_output)
     else
        write (u, "(A)")  char (name) // " = [undefined]"
     end if
   end subroutine var_list_write_var
 
 @ %def var_list_write_var
 @
 \subsection{Tools}
 Return a pointer to the variable list linked to by the current one.
 <<Variables: procedures>>=
   function var_list_get_next_ptr (var_list) result (next_ptr)
     type(var_list_t), pointer :: next_ptr
     type(var_list_t), intent(in) :: var_list
     next_ptr => var_list%next
   end function var_list_get_next_ptr
 
 @ %def var_list_get_next_ptr
 @ Used by [[eval_trees]]:
 Return a pointer to the variable with the requested name.  If no such
 name exists, return a null pointer.  In that case, try the next list
 if present, unless [[follow_link]] is unset.  If [[defined]] is set, ignore
 entries that exist but are undefined.
 <<Variables: public>>=
   public :: var_list_get_var_ptr
 <<Variables: procedures>>=
   recursive function var_list_get_var_ptr &
        (var_list, name, type, follow_link, defined) result (var)
     type(var_entry_t), pointer :: var
     type(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: type
     logical, intent(in), optional :: follow_link, defined
     logical :: ignore_undef, search_next
     ignore_undef = .true.;  if (present (defined))  ignore_undef = .not. defined
     var => var_list%first
     if (present (type)) then
        do while (associated (var))
           if (var%type == type) then
              if (var%name == name) then
                 if (ignore_undef .or. var%is_defined)  return
              end if
           end if
           var => var%next
        end do
     else
        do while (associated (var))
           if (var%name == name) then
              if (ignore_undef .or. var%is_defined)  return
           end if
           var => var%next
        end do
     end if
     search_next = associated (var_list%next)
     if (present (follow_link)) &
          search_next = search_next .and. follow_link
     if (search_next) &
          var => var_list_get_var_ptr &
               (var_list%next, name, type, defined=defined)
   end function var_list_get_var_ptr
 
 @ %def var_list_get_var_ptr
 @ Return the variable type
 <<Variables: var list: TBP>>=
   procedure :: get_type => var_list_get_type
 <<Variables: procedures>>=
   function var_list_get_type (var_list, name, follow_link) result (type)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: follow_link
     integer :: type
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, follow_link=follow_link)
     if (associated (var)) then
        type = var%type
     else
        type = V_NONE
     end if
   end function var_list_get_type
 
 @ %def var_list_get_type
 @ Return true if the variable exists in the current list.
 <<Variables: var list: TBP>>=
   procedure :: contains => var_list_exists
 <<Variables: procedures>>=
   function var_list_exists (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     lval = associated (var)
   end function var_list_exists
 
 @ %def var_list_exists
 @ Return true if the variable is declared as intrinsic.  (This is not a
 property of the abstract [[vars_t]] type, and therefore the method is
 not inherited.)
 <<Variables: var list: TBP>>=
   procedure :: is_intrinsic => var_list_is_intrinsic
 <<Variables: procedures>>=
   function var_list_is_intrinsic (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        lval = var%is_intrinsic
     else
        lval = .false.
     end if
   end function var_list_is_intrinsic
 
 @ %def var_list_is_intrinsic
 @ Return true if the value is known.
 <<Variables: var list: TBP>>=
   procedure :: is_known => var_list_is_known
 <<Variables: procedures>>=
   function var_list_is_known (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        lval = var%is_known
     else
        lval = .false.
     end if
   end function var_list_is_known
 
 @ %def var_list_is_known
 @ Return true if the value is locked.  (This is not a
 property of the abstract [[vars_t]] type, and therefore the method is
 not inherited.)
 <<Variables: var list: TBP>>=
   procedure :: is_locked => var_list_is_locked
 <<Variables: procedures>>=
   function var_list_is_locked (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        lval = var_entry_is_locked (var)
     else
        lval = .false.
     end if
   end function var_list_is_locked
 
 @ %def var_list_is_locked
 @ Return several properties at once.
 <<Variables: var list: TBP>>=
   procedure :: get_var_properties => var_list_get_var_properties
 <<Variables: procedures>>=
   subroutine var_list_get_var_properties (vars, name, req_type, follow_link, &
        type, is_defined, is_known, is_locked)
     class(var_list_t), intent(in) :: vars
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: req_type
     logical, intent(in), optional :: follow_link
     integer, intent(out), optional :: type
     logical, intent(out), optional :: is_defined, is_known, is_locked
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, type=req_type, follow_link=follow_link)
     if (associated (var)) then
        if (present (type))  type = var_entry_get_type (var)
        if (present (is_defined))  is_defined = var_entry_is_defined (var)
        if (present (is_known))  is_known = var_entry_is_known (var)
        if (present (is_locked))  is_locked = var_entry_is_locked (var)
     else
        if (present (type))  type = V_NONE
        if (present (is_defined))  is_defined = .false.
        if (present (is_known))  is_known = .false.
        if (present (is_locked))  is_locked = .false.
     end if
   end subroutine var_list_get_var_properties
 
 @ %def var_list_get_var_properties
 @ Return the value, assuming that the type is correct.  We consider only
 variable entries that have been [[defined]].
 
 For convenience, allow both variable and fixed-length (literal) strings.
 <<Variables: var list: TBP>>=
   procedure :: get_lval => var_list_get_lval
   procedure :: get_ival => var_list_get_ival
   procedure :: get_rval => var_list_get_rval
   procedure :: get_cval => var_list_get_cval
   procedure :: get_pval => var_list_get_pval
   procedure :: get_aval => var_list_get_aval
   procedure :: get_sval => var_list_get_sval
 <<Variables: procedures>>=
   function var_list_get_lval (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_LOG, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           lval = var%lval
        else
           lval = .false.
        end if
     else
        lval = .false.
     end if
   end function var_list_get_lval
 
   function var_list_get_ival (vars, name, follow_link) result (ival)
     integer :: ival
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_INT, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           ival = var%ival
        else
           ival = 0
        end if
     else
        ival = 0
     end if
   end function var_list_get_ival
 
   function var_list_get_rval (vars, name, follow_link) result (rval)
     real(default) :: rval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_REAL, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           rval = var%rval
        else
           rval = 0
        end if
     else
        rval = 0
     end if
   end function var_list_get_rval
 
   function var_list_get_cval (vars, name, follow_link) result (cval)
     complex(default) :: cval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_CMPLX, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           cval = var%cval
        else
           cval = 0
        end if
     else
        cval = 0
     end if
   end function var_list_get_cval
 
   function var_list_get_aval (vars, name, follow_link) result (aval)
     type(pdg_array_t) :: aval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_PDG, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           aval = var%aval
        end if
     end if
   end function var_list_get_aval
 
   function var_list_get_pval (vars, name, follow_link) result (pval)
     type(subevt_t) :: pval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_SEV, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           pval = var%pval
        end if
     end if
   end function var_list_get_pval
 
   function var_list_get_sval (vars, name, follow_link) result (sval)
     type(string_t) :: sval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_STR, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           sval = var%sval
        else
           sval = ""
        end if
     else
        sval = ""
     end if
   end function var_list_get_sval
 
 @ %def var_list_get_lval
 @ %def var_list_get_ival
 @ %def var_list_get_rval
 @ %def var_list_get_cval
 @ %def var_list_get_pval
 @ %def var_list_get_aval
 @ %def var_list_get_sval
 @ Check for a valid value, given a pointer.  Issue error messages if invalid.
 <<Variables: procedures>>=
   function var_has_value (var) result (valid)
     logical :: valid
     type(var_entry_t), pointer :: var
     if (associated (var)) then
        if (var%is_known) then
           valid = .true.
        else
           call msg_error ("The value of variable '" // char (var%name) &
                // "' is unknown but must be known at this point.")
           valid = .false.
        end if
     else
        call msg_error ("Variable '" // char (var%name) &
             // "' is undefined but must have a known value at this point.")
        valid = .false.
     end if
   end function var_has_value
 
 @ %def var_has_value
 @ Return pointers instead of values, including a pointer to the
 [[known]] entry.
 <<Variables: var list: TBP>>=
   procedure :: get_lptr => var_list_get_lptr
   procedure :: get_iptr => var_list_get_iptr
   procedure :: get_rptr => var_list_get_rptr
   procedure :: get_cptr => var_list_get_cptr
   procedure :: get_aptr => var_list_get_aptr
   procedure :: get_pptr => var_list_get_pptr
   procedure :: get_sptr => var_list_get_sptr
 <<Variables: procedures>>=
   subroutine var_list_get_lptr (var_list, name, lptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     logical, pointer, intent(out) :: lptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_LOG)
     if (associated (var)) then
        lptr => var_entry_get_lval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        lptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_lptr
 
   subroutine var_list_get_iptr (var_list, name, iptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     integer, pointer, intent(out) :: iptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_INT)
     if (associated (var)) then
        iptr => var_entry_get_ival_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        iptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_iptr
 
   subroutine var_list_get_rptr (var_list, name, rptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     real(default), pointer, intent(out) :: rptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_REAL)
     if (associated (var)) then
        rptr => var_entry_get_rval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        rptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_rptr
 
   subroutine var_list_get_cptr (var_list, name, cptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     complex(default), pointer, intent(out) :: cptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_CMPLX)
     if (associated (var)) then
        cptr => var_entry_get_cval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        cptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_cptr
 
   subroutine var_list_get_aptr (var_list, name, aptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     type(pdg_array_t), pointer, intent(out) :: aptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_PDG)
     if (associated (var)) then
        aptr => var_entry_get_aval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        aptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_aptr
 
   subroutine var_list_get_pptr (var_list, name, pptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     type(subevt_t), pointer, intent(out) :: pptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_SEV)
     if (associated (var)) then
        pptr => var_entry_get_pval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        pptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_pptr
 
   subroutine var_list_get_sptr (var_list, name, sptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     type(string_t), pointer, intent(out) :: sptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_STR)
     if (associated (var)) then
        sptr => var_entry_get_sval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        sptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_sptr
 
 @ %def var_list_get_lptr
 @ %def var_list_get_iptr
 @ %def var_list_get_rptr
 @ %def var_list_get_cptr
 @ %def var_list_get_aptr
 @ %def var_list_get_pptr
 @ %def var_list_get_sptr
 @
 This bunch of methods handles the procedure-pointer cases.
 <<Variables: var list: TBP>>=
   procedure :: get_obs1_iptr => var_list_get_obs1_iptr
   procedure :: get_obs2_iptr => var_list_get_obs2_iptr
   procedure :: get_obs1_rptr => var_list_get_obs1_rptr
   procedure :: get_obs2_rptr => var_list_get_obs2_rptr
 <<Variables: procedures>>=
   subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_unary_int), pointer, intent(out) :: obs1_iptr
     type(prt_t), pointer, intent(out) :: p1
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBS1_INT)
     if (associated (var)) then
        call var_entry_assign_obs1_int_ptr (obs1_iptr, var)
        p1 => var_entry_get_prt1_ptr (var)
     else
        obs1_iptr => null ()
        p1 => null ()
     end if
   end subroutine var_list_get_obs1_iptr
 
   subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_binary_int), pointer, intent(out) :: obs2_iptr
     type(prt_t), pointer, intent(out) :: p1, p2
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBS2_INT)
     if (associated (var)) then
        call var_entry_assign_obs2_int_ptr (obs2_iptr, var)
        p1 => var_entry_get_prt1_ptr (var)
        p2 => var_entry_get_prt2_ptr (var)
     else
        obs2_iptr => null ()
        p1 => null ()
        p2 => null ()
     end if
   end subroutine var_list_get_obs2_iptr
 
   subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_unary_real), pointer, intent(out) :: obs1_rptr
     type(prt_t), pointer, intent(out) :: p1
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBS1_REAL)
     if (associated (var)) then
        call var_entry_assign_obs1_real_ptr (obs1_rptr, var)
        p1 => var_entry_get_prt1_ptr (var)
     else
        obs1_rptr => null ()
        p1 => null ()
     end if
   end subroutine var_list_get_obs1_rptr
 
   subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_binary_real), pointer, intent(out) :: obs2_rptr
     type(prt_t), pointer, intent(out) :: p1, p2
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBS2_REAL)
     if (associated (var)) then
        call var_entry_assign_obs2_real_ptr (obs2_rptr, var)
        p1 => var_entry_get_prt1_ptr (var)
        p2 => var_entry_get_prt2_ptr (var)
     else
        obs2_rptr => null ()
        p1 => null ()
        p2 => null ()
     end if
   end subroutine var_list_get_obs2_rptr
 
 @ %def var_list_get_obs1_iptr
 @ %def var_list_get_obs2_iptr
 @ %def var_list_get_obs1_rptr
 @ %def var_list_get_obs2_rptr
 @
 \subsection{Process Result Variables}
 These variables are associated to process (integration) runs and their
 results.  Their names contain brackets (so they look like function
 evaluations), therefore we need to special-case them.
 <<Variables: public>>=
   public :: var_list_set_procvar_int
   public :: var_list_set_procvar_real
 <<Variables: procedures>>=
   subroutine var_list_set_procvar_int (var_list, proc_id, name, ival)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: proc_id
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: ival
     type(string_t) :: var_name
     type(var_entry_t), pointer :: var
     var_name = name // "(" // proc_id // ")"
     var => var_list_get_var_ptr (var_list, var_name)
     if (.not. associated (var)) then
        call var_list%append_int (var_name, ival, intrinsic=.true.)
     else if (present (ival)) then
        call var_list%set_int (var_name, ival, is_known=.true.)
     end if
   end subroutine var_list_set_procvar_int
 
   subroutine var_list_set_procvar_real (var_list, proc_id, name, rval)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: proc_id
     type(string_t), intent(in) :: name
     real(default), intent(in), optional :: rval
     type(string_t) :: var_name
     type(var_entry_t), pointer :: var
     var_name = name // "(" // proc_id // ")"
     var => var_list_get_var_ptr (var_list, var_name)
     if (.not. associated (var)) then
        call var_list%append_real (var_name, rval, intrinsic=.true.)
     else if (present (rval)) then
        call var_list%set_real (var_name, rval, is_known=.true.)
     end if
   end subroutine var_list_set_procvar_real
 
 @ %def var_list_set_procvar_int
 @ %def var_list_set_procvar_real
 @
 \subsection{Observable initialization}
 Observables are formally treated as variables, which however are
 evaluated each time the observable is used.  The arguments (pointers)
 to evaluate and the function are part of the variable-list entry.
 <<Variables: public>>=
   public :: var_list_append_obs1_iptr
   public :: var_list_append_obs2_iptr
   public :: var_list_append_obs1_rptr
   public :: var_list_append_obs2_rptr
 <<Variables: procedures>>=
   subroutine var_list_append_obs1_iptr (var_list, name, obs1_iptr, p1)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_unary_int) :: obs1_iptr
     type(prt_t), intent(in), target :: p1
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs (var, name, V_OBS1_INT, p1)
     var%obs1_int => obs1_iptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obs1_iptr
 
   subroutine var_list_append_obs2_iptr (var_list, name, obs2_iptr, p1, p2)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_binary_int) :: obs2_iptr
     type(prt_t), intent(in), target :: p1, p2
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs (var, name, V_OBS2_INT, p1, p2)
     var%obs2_int => obs2_iptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obs2_iptr
 
   subroutine var_list_append_obs1_rptr (var_list, name, obs1_rptr, p1)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_unary_real) :: obs1_rptr
     type(prt_t), intent(in), target :: p1
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs (var, name, V_OBS1_REAL, p1)
     var%obs1_real => obs1_rptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obs1_rptr
 
   subroutine var_list_append_obs2_rptr (var_list, name, obs2_rptr, p1, p2)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_binary_real) :: obs2_rptr
     type(prt_t), intent(in), target :: p1, p2
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs (var, name, V_OBS2_REAL, p1, p2)
     var%obs2_real => obs2_rptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obs2_rptr
 
 @ %def var_list_append_obs1_iptr
 @ %def var_list_append_obs2_iptr
 @ %def var_list_append_obs1_rptr
 @ %def var_list_append_obs2_rptr
 @ User observables: no pointer needs to be stored.
 <<Variables: public>>=
   public :: var_list_append_uobs_int
   public :: var_list_append_uobs_real
 <<Variables: procedures>>=
   subroutine var_list_append_uobs_int (var_list, name, p1, p2)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(prt_t), intent(in), target :: p1
     type(prt_t), intent(in), target, optional :: p2
     type(var_entry_t), pointer :: var
     allocate (var)
     if (present (p2)) then
        call var_entry_init_obs (var, name, V_UOBS2_INT, p1, p2)
     else
        call var_entry_init_obs (var, name, V_UOBS1_INT, p1)
     end if
     call var_list_append (var_list, var)
   end subroutine var_list_append_uobs_int
 
   subroutine var_list_append_uobs_real (var_list, name, p1, p2)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(prt_t), intent(in), target :: p1
     type(prt_t), intent(in), target, optional :: p2
     type(var_entry_t), pointer :: var
     allocate (var)
     if (present (p2)) then
        call var_entry_init_obs (var, name, V_UOBS2_REAL, p1, p2)
     else
        call var_entry_init_obs (var, name, V_UOBS1_REAL, p1)
     end if
     call var_list_append (var_list, var)
   end subroutine var_list_append_uobs_real
 
 @ %def var_list_append_uobs_int
 @ %def var_list_append_uobs_real
 @
 \subsection{API for variable lists}
 Set a new value.  If the variable holds a pointer, this pointer is
 followed, e.g., a model parameter is actually set.  If [[ignore]] is
 set, do nothing if the variable does not exist.  If [[verbose]] is
 set, echo the new value.
 
 Clear a variable (all variables), i.e., undefine the value.
 <<Variables: var list: TBP>>=
   procedure :: unset => var_list_clear
 <<Variables: procedures>>=
   subroutine var_list_clear (vars, name, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_clear (var)
     end if
   end subroutine var_list_clear
 
 @ %def var_list_clear
 @
 Setting the value, concise specific versions (implementing deferred TBP):
 <<Variables: var list: TBP>>=
   procedure :: set_ival => var_list_set_ival
   procedure :: set_rval => var_list_set_rval
   procedure :: set_cval => var_list_set_cval
   procedure :: set_lval => var_list_set_lval
   procedure :: set_sval => var_list_set_sval
 <<Variables: procedures>>=
   subroutine var_list_set_ival (vars, name, ival, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     integer, intent(in) :: ival
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_int (var, ival, is_known=.true.)
     end if
   end subroutine var_list_set_ival
 
   subroutine var_list_set_rval (vars, name, rval, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     real(default), intent(in) :: rval
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_real (var, rval, is_known=.true.)
     end if
   end subroutine var_list_set_rval
 
   subroutine var_list_set_cval (vars, name, cval, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     complex(default), intent(in) :: cval
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_cmplx (var, cval, is_known=.true.)
     end if
   end subroutine var_list_set_cval
 
   subroutine var_list_set_lval (vars, name, lval, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     logical, intent(in) :: lval
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_log (var, lval, is_known=.true.)
     end if
   end subroutine var_list_set_lval
 
   subroutine var_list_set_sval (vars, name, sval, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: sval
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_string (var, sval, is_known=.true.)
     end if
   end subroutine var_list_set_sval
 
 @ %def var_list_set_ival
 @ %def var_list_set_rval
 @ %def var_list_set_cval
 @ %def var_list_set_lval
 @ %def var_list_set_sval
 @
 Setting the value, verbose specific versions (as subroutines):
 <<Variables: var list: TBP>>=
   procedure :: set_log => var_list_set_log
   procedure :: set_int => var_list_set_int
   procedure :: set_real => var_list_set_real
   procedure :: set_cmplx => var_list_set_cmplx
   procedure :: set_subevt => var_list_set_subevt
   procedure :: set_pdg_array => var_list_set_pdg_array
   procedure :: set_string => var_list_set_string
 <<Variables: procedures>>=
   subroutine var_list_set_log &
        (var_list, name, lval, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     logical, intent(in) :: lval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_LOG)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_LOG)
              call var_entry_set_log (var, lval, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_log
 
   subroutine var_list_set_int &
        (var_list, name, ival, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in) :: ival
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_INT)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_INT)
              call var_entry_set_int (var, ival, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_int
 
   subroutine var_list_set_real &
        (var_list, name, rval, is_known, ignore, force, &
         verbose, model_name, pacified)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     real(default), intent(in) :: rval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose, pacified
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_REAL)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_REAL)
              call var_entry_set_real &
                   (var, rval, is_known, verbose, model_name, pacified)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_real
 
   subroutine var_list_set_cmplx &
        (var_list, name, cval, is_known, ignore, force, &
         verbose, model_name, pacified)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     complex(default), intent(in) :: cval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose, pacified
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_CMPLX)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_CMPLX)
              call var_entry_set_cmplx &
                   (var, cval, is_known, verbose, model_name, pacified)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_cmplx
 
   subroutine var_list_set_pdg_array &
        (var_list, name, aval, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in) :: aval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_PDG)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_PDG)
              call var_entry_set_pdg_array &
                   (var, aval, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_pdg_array
 
   subroutine var_list_set_subevt &
        (var_list, name, pval, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in) :: pval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_SEV)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_SEV)
              call var_entry_set_subevt &
                   (var, pval, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_subevt
 
   subroutine var_list_set_string &
        (var_list, name, sval, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: sval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_STR)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_STR)
              call var_entry_set_string &
                   (var, sval, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_string
 
   subroutine var_mismatch_error (name)
     type(string_t), intent(in) :: name
     call msg_fatal ("Type mismatch for variable '" // char (name) // "'")
   end subroutine var_mismatch_error
 
   subroutine var_locked_error (name)
     type(string_t), intent(in) :: name
     call msg_error ("Variable '" // char (name) // "' is not user-definable")
   end subroutine var_locked_error
 
   subroutine var_missing_error (name, ignore)
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: ignore
     logical :: error
     if (present (ignore)) then
        error = .not. ignore
     else
        error = .true.
     end if
     if (error) then
        call msg_fatal ("Variable '" // char (name) // "' has not been declared")
     end if
   end subroutine var_missing_error
 
 @ %def var_list_set_log
 @ %def var_list_set_int
 @ %def var_list_set_real
 @ %def var_list_set_cmplx
 @ %def var_list_set_subevt
 @ %def var_list_set_pdg_array
 @ %def var_list_set_string
 @ %def var_mismatch_error
 @ %def var_missing_error
 @
 Import values for the current variable list from another list.
 <<Variables: public>>=
   public :: var_list_import
 <<Variables: var list: TBP>>=
   procedure :: import => var_list_import
 <<Variables: procedures>>=
   subroutine var_list_import (var_list, src_list)
     class(var_list_t), intent(inout) :: var_list
     type(var_list_t), intent(in) :: src_list
     type(var_entry_t), pointer :: var, src
     var => var_list%first
     do while (associated (var))
        src => var_list_get_var_ptr (src_list, var%name)
        if (associated (src)) then
           call var_entry_copy_value (var, src)
        end if
        var => var%next
     end do
   end subroutine var_list_import
 
 @ %def var_list_import
 @ Mark all entries in the current variable list as undefined.  This is done
 when a local variable list is discarded.  If the local list is used again (by
 a loop), the entries will be re-initialized.
 <<Variables: public>>=
   public :: var_list_undefine
 <<Variables: var list: TBP>>=
   procedure :: undefine => var_list_undefine
 <<Variables: procedures>>=
   recursive subroutine var_list_undefine (var_list, follow_link)
     class(var_list_t), intent(inout) :: var_list
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     logical :: rec
     rec = .true.;  if (present (follow_link))  rec = follow_link
     var => var_list%first
     do while (associated (var))
        call var_entry_undefine (var)
        var => var%next
     end do
     if (rec .and. associated (var_list%next)) then
        call var_list_undefine (var_list%next, follow_link=follow_link)
     end if
   end subroutine var_list_undefine
 
 @ %def var_list_undefine
 @ Make a deep copy of a variable list.
 <<Variables: public>>=
   public :: var_list_init_snapshot
 <<Variables: var list: TBP>>=
   procedure :: init_snapshot => var_list_init_snapshot
 <<Variables: procedures>>=
   recursive subroutine var_list_init_snapshot (var_list, vars_in, follow_link)
     class(var_list_t), intent(out) :: var_list
     type(var_list_t), intent(in) :: vars_in
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var, var_in
     type(var_list_t), pointer :: var_list_next
     logical :: rec
     rec = .true.;  if (present (follow_link))  rec = follow_link
     var_in => vars_in%first
     do while (associated (var_in))
        allocate (var)
        call var_entry_init_copy (var, var_in)
        call var_entry_copy_value (var, var_in)
        call var_list_append (var_list, var)
        var_in => var_in%next
     end do
     if (rec .and. associated (vars_in%next)) then
        allocate (var_list_next)
        call var_list_init_snapshot (var_list_next, vars_in%next)
        call var_list%link (var_list_next)
     end if
   end subroutine var_list_init_snapshot
 
 @ %def var_list_init_snapshot
 @ Check if a user variable can be set.  The [[new]] flag is set if the user
 variable has an explicit declaration.  If an error occurs, return [[V_NONE]]
 as variable type.
 
 Also determine the actual type of generic numerical variables, which enter the
 procedure with type [[V_NONE]].
 <<Variables: public>>=
   public :: var_list_check_user_var
 <<Variables: var list: TBP>>=
   procedure :: check_user_var => var_list_check_user_var
 <<Variables: procedures>>=
   subroutine var_list_check_user_var (var_list, name, type, new)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(inout) :: type
     logical, intent(in) :: new
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name)
     if (associated (var)) then
        if (type == V_NONE) then
           type = var_entry_get_type (var)
        end if
        if (var_entry_is_locked (var)) then
           call msg_fatal ("Variable '" // char (name) &
                // "' is not user-definable")
           type = V_NONE
           return
        else if (new) then
           if (var_entry_is_intrinsic (var)) then
              call msg_fatal ("Intrinsic variable '" &
                   // char (name) // "' redeclared")
              type = V_NONE
              return
           end if
           if (var_entry_get_type (var) /= type) then
              call msg_fatal ("Variable '" // char (name) // "' " &
                   // "redeclared with different type")
              type = V_NONE
              return
           end if
        end if
     end if
   end subroutine var_list_check_user_var
 
 @ %def var_list_check_user_var
 @
 \subsection{Default values for global var list}
 
 <<Variables: var list: TBP>>=
   procedure :: init_defaults => var_list_init_defaults
 <<Variables: procedures>>=
   subroutine var_list_init_defaults (var_list, seed, paths)
     class(var_list_t), intent(out) :: var_list
     integer, intent(in) :: seed
     type(paths_t), intent(in), optional :: paths
     call var_list%set_beams_defaults (paths)
     call var_list%set_core_defaults (seed)
     call var_list%set_integration_defaults ()
     call var_list%set_phase_space_defaults ()
     call var_list%set_gamelan_defaults ()
     call var_list%set_clustering_defaults ()
     call var_list%set_isolation_defaults ()
     call var_list%set_eio_defaults ()
     call var_list%set_shower_defaults ()
     call var_list%set_hadronization_defaults ()
     call var_list%set_tauola_defaults  ()
     call var_list%set_mlm_matching_defaults ()
     call var_list%set_powheg_matching_defaults ()
     call var_list%append_log (var_str ("?ckkw_matching"), .false., &
             intrinsic=.true., description=var_str ('Master flag that switches ' // &
             'on the CKKW(-L) (LO) matching between hard scattering matrix ' // &
             'elements and QCD parton showers. Note that this is not yet ' // &
             '(completely) implemented in \whizard. (cf. also \ttt{?allow\_shower}, ' // &
             '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})'))
     call var_list%set_openmp_defaults ()
     call var_list%set_mpi_defaults ()
     call var_list%set_nlo_defaults ()
   end subroutine var_list_init_defaults
 
 @ %def var_list_init_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_beams_defaults => var_list_set_beams_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_beams_defaults (var_list, paths)
     type(paths_t), intent(in), optional :: paths
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_real (var_str ("sqrts"), &
           intrinsic=.true., &
           description=var_str ('Real variable in order to set the center-of-mass ' // &
           'energy for the collisions (collider energy $\sqrt{s}$, not ' // &
           'hard interaction energy $\sqrt{\hat{s}}$): \ttt{sqrts = {\em ' // &
           '<num>} [ {\em <phys\_unit>} ]}. The physical unit can be one ' // &
           'of the following \ttt{eV}, \ttt{keV}, \ttt{MeV}, \ttt{GeV}, ' // &
           'and \ttt{TeV}. If absent, \whizard\ takes \ttt{GeV} as its ' // &
           'standard unit. Note that this variable is absolutely mandatory ' // &
           'for integration and simulation of scattering processes.'))
     call var_list%append_real (var_str ("luminosity"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This specifier \ttt{luminosity = {\em ' // &
           '<num>}} sets the integrated luminosity (in inverse femtobarns, ' // &
           'fb${}^{-1}$) for the event generation of the processes in the ' // &
           '\sindarin\ input files. Note that WHIZARD itself chooses the ' // &
           'number from the \ttt{luminosity} or from the \ttt{n\_events} ' // &
           'specifier, whichever would give the larger number of events. ' // &
           'As this depends on the cross section under consideration, it ' // &
           'might be different for different processes in the process list.  ' // &
           '(cf. \ttt{n\_events}, \ttt{\$sample}, \ttt{sample\_format}, \ttt{?unweighted})'))
     call var_list%append_log (var_str ("?sf_trace"), .false., &
           intrinsic=.true., &
           description=var_str ('Debug flag that writes out detailed information ' // &
           'about the structure function setup into the file \ttt{{\em ' // &
           '<proc\_name>}\_sftrace.dat}. This file name can be changed ' // &
           'with ($\to$) \ttt{\$sf\_trace\_file}.'))
     call var_list%append_string (var_str ("$sf_trace_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('\ttt{\$sf\_trace\_file = "{\em <file\_name>}"} ' // &
           'allows to change the detailed structure function information ' // &
           'switched on by the debug flag ($\to$) \ttt{?sf\_trace} into ' // &
           'a different file \ttt{{\em <file\_name>}} than the default ' // &
           '\ttt{{\em <proc\_name>}\_sftrace.dat}.'))
     call var_list%append_log (var_str ("?sf_allow_s_mapping"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that determines whether special mappings ' // &
           'for processes with structure functions and $s$-channel resonances ' // &
           'are applied, e.g. Drell-Yan at hadron colliders, or $Z$ production ' // &
           'at linear colliders with beamstrahlung and ISR.'))
     if (present (paths)) then
        call var_list%append_string (var_str ("$lhapdf_dir"), paths%lhapdfdir, &
              intrinsic=.true., &
              description=var_str ('String variable that tells the path ' // &
              'where the \lhapdf\ library and PDF sets can be found. When ' // &
              'the library has been correctly recognized during configuration, ' // &
              'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // &
              '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
              '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})'))
     else
        call var_list%append_string (var_str ("$lhapdf_dir"), var_str(""), &
              intrinsic=.true., &
              description=var_str ('String variable that tells the path ' // &
              'where the \lhapdf\ library and PDF sets can be found. When ' // &
              'the library has been correctly recognized during configuration, ' // &
              'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // &
              '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
              '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})'))
     end if
     call var_list%append_string (var_str ("$lhapdf_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('This string variable \ttt{\$lhapdf\_file ' // &
           '= "{\em <pdf\_set>}"} allows to specify the PDF set \ttt{{\em ' // &
           '<pdf\_set>}} from the external \lhapdf\ library. It must match ' // &
           'the exact name of the PDF set from the \lhapdf\ library. The ' // &
           'default is empty, and the default set from \lhapdf\ is taken. ' // &
           'Only one argument is possible, the PDF set must be identical ' // &
           'for both beams, unless there are fundamentally different beam ' // &
           'particles like proton and photon. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
           '\ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_photon\_scheme}, ' // &
           '\ttt{lhapdf\_member})'))
     call var_list%append_string (var_str ("$lhapdf_photon_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable \ttt{\$lhapdf\_photon\_file ' // &
           '= "{\em <pdf\_set>}"} analagous to ($\to$) \ttt{\$lhapdf\_file} ' // &
           'for photon PDF structure functions from the external \lhapdf\ ' // &
           'library. The name must exactly match the one of the set from ' // &
           '\lhapdf.  (cf. \ttt{beams}, \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
           '\ttt{\$lhapdf\_file}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member}, ' // &
           '\ttt{lhapdf\_photon\_scheme})'))
     call var_list%append_int (var_str ("lhapdf_member"), 0, &
           intrinsic=.true., &
           description=var_str ('Integer variable that specifies the number ' // &
           'of the corresponding PDF set chosen via the command ($\to$) ' // &
           '\ttt{\$lhapdf\_file} or ($\to$) \ttt{\$lhapdf\_photon\_file} ' // &
           'from the external \lhapdf\ library. E.g. error PDF sets can ' // &
           'be chosen by this. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
           '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
           '\ttt{lhapdf\_photon\_scheme})'))
     call var_list%append_int (var_str ("lhapdf_photon_scheme"), 0, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that controls the different ' // &
           'available schemes for photon PDFs inside the external \lhapdf\ ' // &
           'library. For more details see the \lhapdf\ manual.  (cf. also ' // &
           '\ttt{lhapdf}, \ttt{\$lhapdf\_dir}, \ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, ' // &
           '\ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member})'))
     call var_list%append_string (var_str ("$pdf_builtin_set"), var_str ("CTEQ6L"), &
          intrinsic=.true., &
          description=var_str ("For \whizard's internal PDF structure functions " // &
          'for hadron colliders, this string variable allows to set the ' // &
          'particular PDF set. (cf. also \ttt{pdf\_builtin}, \ttt{pdf\_builtin\_photon})'))
     call var_list%append_log (var_str ("?hoppet_b_matching"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that switches on the matching between ' // &
           '4- and 5-flavor schemes for hadron collider $b$-parton initiated ' // &
           'processes. Works either with builtin PDFs or with the external ' // &
           '\lhapdf\ interface. Needs the external \ttt{HOPPET} library ' // &
           'to be linked. (cf. \ttt{beams}, \ttt{pdf\_builtin}, \ttt{lhapdf})'))
     call var_list%append_real (var_str ("isr_alpha"), 0._default, &
           intrinsic=.true., &
           description=var_str ('For lepton collider initial-state QED ' // &
           'radiation (ISR), this real parameter sets the value of $\alpha_{em}$ ' // &
           'used in the structure function. If not set, it is taken from ' // &
           'the parameter set of the physics model in use (cf. also \ttt{isr}, ' // &
           '\ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // &
           '\ttt{?isr\_keep\_energy})'))
     call var_list%append_real (var_str ("isr_q_max"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set the ' // &
           'scale of the initial-state QED radiation (ISR) structure function. ' // &
           'If not set, it is taken internally to be $\sqrt{s}$.  (cf. ' // &
           'also \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // &
           '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})'))
     call var_list%append_real (var_str ("isr_mass"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set by hand ' // &
           'the mass of the incoming particle for lepton collider initial-state ' // &
           'QED radiation (ISR). If not set, the mass for the initial beam ' // &
           'particle is taken from the model in use. (cf. also \ttt{isr}, ' // &
           '\ttt{isr\_q\_max}, \ttt{isr\_alpha}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // &
           '\ttt{?isr\_keep\_energy})'))
     call var_list%append_int (var_str ("isr_order"), 3, &
           intrinsic=.true., &
           description=var_str ('For lepton collider initial-state QED ' // &
           'radiation (ISR), this integer parameter allows to set the order ' // &
           'up to which hard-collinear radiation is taken into account. ' // &
           'Default is the highest available, namely third order. (cf. ' // &
           'also \ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_alpha}, ' // &
           '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})'))
     call var_list%append_log (var_str ("?isr_recoil"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // &
           '$p_T$-kick for the lepton collider initial-state QED radiation ' // &
           '(ISR).  (cf. also \ttt{isr}, \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, ' // &
           '\ttt{isr\_order}, \ttt{isr\_q\_max})'))
     call var_list%append_log (var_str ("?isr_keep_energy"), .false., &
           intrinsic=.true., &
           description=var_str ('As the splitting kinematics for the ISR ' // &
           'structure function violates Lorentz invariance when the recoil ' // &
           'is switched on, this flag forces energy conservation when set ' // &
           'to true, otherwise violating energy conservation.  (cf. also ' // &
           '\ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // &
           '\ttt{?isr\_recoil}, \ttt{?isr\_alpha})'))
     call var_list%append_log (var_str ("?isr_handler"), .false., &
           intrinsic=.true., &
           description=var_str ('Activate ISR ' // &
           'handler for event generation (no effect on integration). ' // &
           'Requires \ttt{isr\_recoil = false}'))
     call var_list%append_string (var_str ("$isr_handler_mode"), &
           var_str ("trivial"), &
           intrinsic=.true., &
           description=var_str ('Operation mode for the ISR ' // &
           'event handler.  Allowed values: \ttt{trivial} (no effect), ' // &
           '\ttt{recoil} (recoil kinematics with two photons)'))
     call var_list%append_log (var_str ("?isr_handler_keep_mass"), .true., &
           intrinsic=.true., &
           description=var_str ('If \ttt{true} (default), force the incoming ' // &
           'partons of the hard process (after radiation) on their mass ' // &
           'shell.  Otherwise, insert massless on-shell momenta.  This ' // &
           'applies only for event generation (no effect on integration, ' // &
           'cf.\ also \ttt{?isr\_handler})'))
     call var_list%append_string (var_str ("$epa_mode"), &
           var_str ("default"), intrinsic=.true., &
           description=var_str ('For the equivalent photon approximation ' // &
           '(EPA), this string variable defines the mode, i.e. the explicit ' // &
           'formula for the EPA distribution. For more details cf. the manual. ' // &
           'Possible are \ttt{default} (\ttt{Budnev\_617}), \ttt{Budnev\_616e}, ' // &
           '\ttt{log\_power}, \ttt{log\_simple}, and \ttt{log}. ' // &
           '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, ' // &
           '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_alpha"), 0._default, &
           intrinsic=.true., &
           description=var_str ('For the equivalent photon approximation ' // &
           '(EPA), this real parameter sets the value of $\alpha_{em}$ ' // &
           'used in the structure function. If not set, it is taken from ' // &
           'the parameter set of the physics model in use (cf. also \ttt{epa}, ' // &
           '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, \ttt{epa\_q\_min}, ' // &
           '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_x_min"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the lower cutoff ' // &
           'for the energy fraction in the splitting for the equivalent-photon ' // &
           'approximation (EPA). This parameter has to be set by the user ' // &
           'to a non-zero value smaller than one. (cf. also \ttt{epa}, ' // &
           '\ttt{epa\_e\_max}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // &
           '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
                     '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_q_min"), 0._default, &
           intrinsic=.true., &
           description=var_str ('In the equivalent-photon approximation ' // &
           '(EPA), this real parameters sets the minimal value for the ' // &
           'transferred momentum. Either this parameter or the mass of ' // &
           'the beam particle has to be non-zero.  (cf. also \ttt{epa}, ' // &
           '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_max}, ' // &
           '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_q_max"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set the ' // &
           'upper energy cutoff for the equivalent-photon approximation ' // &
           '(EPA). If not set, \whizard\ simply takes the collider energy, ' // &
           '$\sqrt{s}$. (cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, ' // &
           '\ttt{epa\_alpha}, \ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // &
           '\ttt{?epa\_keep\_energy}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_mass"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set by hand ' // &
           'the mass of the incoming particle for the equivalent-photon ' // &
           'approximation (EPA). If not set, the mass for the initial beam ' // &
           'particle is taken from the model in use. (cf. also \ttt{epa}, ' // &
           '\ttt{epa\_x\_min}, \ttt{epa\_e\_max}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // &
           '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}. ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_log (var_str ("?epa_recoil"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // &
           '$p_T$-kick for the equivalent-photon approximation (EPA).  ' // &
           '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // &
           '\ttt{epa\_e\_max}, \ttt{epa\_q\_min}, \ttt{?epa\_keep\_energy}, ' // &
           '\ttt{\$epa\_mode}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_log (var_str ("?epa_keep_energy"), .false., &
           intrinsic=.true., &
           description=var_str ('As the splitting kinematics for the EPA ' // &
           'structure function violates Lorentz invariance when the recoil ' // &
           'is switched on, this flag forces energy conservation when set ' // &
           'to true, otherwise violating energy conservation. (cf. also ' // &
           '\ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // &
           '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_log (var_str ("?epa_handler"), .false., &
           intrinsic=.true., &
           description=var_str ('Activate EPA ' // &
           'handler for event generation (no effect on integration). ' // &
           'Requires \ttt{epa\_recoil = false}'))
     call var_list%append_string (var_str ("$epa_handler_mode"), &
           var_str ("trivial"), &
           intrinsic=.true., &
           description=var_str ('Operation mode for the EPA ' // &
           'event handler.  Allowed values: \ttt{trivial} (no effect), ' // &
           '\ttt{recoil} (recoil kinematics with two beams)'))
     call var_list%append_real (var_str ("ewa_x_min"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the lower cutoff ' // &
           'for the energy fraction in the splitting for the equivalent ' // &
           '$W$ approximation (EWA). This parameter has to be set by the ' // &
           'user to a non-zero value smaller than one. (cf. also \ttt{ewa}, ' // &
           '\ttt{ewa\_pt\_max}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // &
           '\ttt{?ewa\_recoil})'))
     call var_list%append_real (var_str ("ewa_pt_max"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set the ' // &
           'upper $p_T$ cutoff for the equivalent $W$ approximation (EWA). ' // &
           'If not set, \whizard\ simply takes the collider energy, $\sqrt{s}$. ' // &
           '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // &
           '\ttt{?ewa\_recoil})'))
     call var_list%append_real (var_str ("ewa_mass"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set by hand ' // &
           'the mass of the incoming particle for the equivalent $W$ approximation ' // &
           '(EWA). If not set, the mass for the initial beam particle is ' // &
           'taken from the model in use. (cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, ' // &
           '\ttt{ewa\_pt\_max}, \ttt{?ewa\_keep\_energy}, \ttt{?ewa\_recoil})'))
     call var_list%append_log (var_str ("?ewa_recoil"), .false., &
          intrinsic=.true., &
          description=var_str ('For the equivalent $W$ approximation (EWA), ' // &
          'this flag switches on recoil, i.e. non-collinear splitting.  ' // &
          '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max},  ' // &
          '\ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy})'))
     call var_list%append_log (var_str ("?ewa_keep_energy"), .false., &
           intrinsic=.true., &
           description=var_str ('As the splitting kinematics for the equivalent ' // &
           '$W$ approximation (EWA) violates Lorentz invariance when the ' // &
           'recoil is switched on, this flag forces energy conservation ' // &
           'when set to true, otherwise violating energy conservation. ' // &
           '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max},  ' // &
           '\ttt{ewa\_mass}, \ttt{?ewa\_recoil})'))
     call var_list%append_log (var_str ("?circe1_photon1"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to tell \whizard\ to use the photon ' // &
           'of the \circeone\ beamstrahlung structure function as initiator ' // &
           'for the hard scattering process in the first beam. (cf. also ' // &
           '\ttt{circe1}, \ttt{?circe1\_photon2}, \ttt{circe1\_sqrts},  ' // &
           '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
           '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
           '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
           '\ttt{?circe1\_with\_radiation})'))
     call var_list%append_log (var_str ("?circe1_photon2"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to tell \whizard\ to use the photon ' // &
           'of the \circeone\ beamstrahlung structure function as initiator ' // &
           'for the hard scattering process in the second beam. (cf. also ' // &
           '\ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{circe1\_sqrts},  ' // &
           '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
           '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
           '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // &
           '\newline\ttt{?circe1\_with\_radiation})'))
     call var_list%append_real (var_str ("circe1_sqrts"), &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows to set the ' // &
           'value of the collider energy for the lepton collider beamstrahlung ' // &
           'structure function \circeone. If not set, $\sqrt{s}$ is taken. ' // &
           '(cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2},  ' // &
           '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
           '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
           '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
           '\ttt{?circe1\_with\_radiation})'))
     call var_list%append_log (var_str ("?circe1_generate"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that determines whether the \circeone\ ' // &
           'structure function for lepton collider beamstrahlung uses the ' // &
           'generator mode for the spectrum, or a pre-defined (semi-)analytical ' // &
           'parameterization. Default is the generator mode. (cf. also ' // &
           '\ttt{circe1}, \ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2},  ' // &
           '\ttt{circe1\_sqrts}, \ttt{?circe1\_map}, \ttt{circe1\_mapping\_slope}, ' // &
           '\ttt{circe1\_eps}, \newline \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // &
           '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_log (var_str ("?circe1_map"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that determines whether the \circeone\ ' // &
           'structure function for lepton collider beamstrahlung uses special ' // &
           'mappings for $s$-channel resonances. (cf. also \ttt{circe1}, ' // &
           '\ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2},  ' // &
           '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // &
           '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_eps}, \newline ' // &
           '\ttt{circe1\_ver}, \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, ' // &
           '\ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_real (var_str ("circe1_mapping_slope"), 2._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows to vary the ' // &
           'slope of the mapping function for the \circeone\ structure ' // &
           'function for lepton collider beamstrahlung from the default ' // &
           'value \ttt{2.}. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // &
           '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts},  \ttt{?circe1\_generate}, ' // &
           '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \ttt{circe1\_ver}, ' // &
           '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
           '\ttt{?circe1\_with\_radiation})'))
     call var_list%append_real (var_str ("circe1_eps"), 1e-5_default, &
           intrinsic=.true., &
           description=var_str ('Real parameter, that takes care of the ' // &
           'mapping of the peak in the lepton collider beamstrahlung structure ' // &
           'function spectrum of \circeone.  (cf. also \ttt{circe1}, \ttt{?circe1\_photons}, ' // &
           '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // &
           '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \newline ' // &
           '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // &
           '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline\ttt{?circe1\_with\_radiation})'))
     call var_list%append_int (var_str ("circe1_ver"), 0, intrinsic=.true., &
          description=var_str ('Integer parameter that sets the internal ' // &
          'versioning number of the \circeone\ structure function for lepton-collider ' // &
          'beamstrahlung. It has to be set by the user explicitly, it takes ' // &
          'values from one to ten.  (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // &
          '\ttt{?circe1\_photon2},  \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
          '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, ' // &
          '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // &
          '\ttt{?circe1\_with\_radiation})'))
     call var_list%append_int (var_str ("circe1_rev"), 0, intrinsic=.true., &
          description=var_str ('Integer parameter that sets the internal ' // &
          'revision number of the \circeone\ structure function for lepton-collider ' // &
          'beamstrahlung. The default \ttt{0} translates always into the ' // &
          'most recent version; older versions have to be accessed through ' // &
          'the explicit revision date. For more details cf.~the \circeone ' // &
          'manual.  (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2},  ' // &
          '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
          '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, \ttt{circe1\_ver}, ' // &
          '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_string (var_str ("$circe1_acc"), var_str ("SBAND"), &
           intrinsic=.true., &
           description=var_str ('String variable that specifies the accelerator ' // &
           'type for the \circeone\ structure function for lepton-collider ' // &
           'beamstrahlung.  (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
           '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
           '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
           '\newline \ttt{circe1\_rev}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_int (var_str ("circe1_chat"), 0, intrinsic=.true., &
          description=var_str ('Chattiness of the \circeone\ structure ' // &
          'function for lepton-collider beamstrahlung. The higher the integer ' // &
          'value, the more information will be given out by the \circeone\ ' // &
          'package. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
          '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
          '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
          '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_log (var_str ("?circe1_with_radiation"), .false., &
          intrinsic=.true., &
          description=var_str ('This logical decides whether the additional photon ' // &
          'or electron ("beam remnant") will be considered in the event record or ' // &
          'not. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
          '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
          '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
          '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc})'))
     call var_list%append_log (var_str ("?circe2_polarized"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag whether the photon spectra from the ' // &
           '\circetwo\ structure function for lepton colliders should be ' // &
           'treated polarized. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, ' // &
           '\ttt{\$circe2\_design})'))
     call var_list%append_string (var_str ("$circe2_file"), &
           intrinsic=.true., &
           description=var_str ('String variable by which the corresponding ' // &
           'photon collider spectrum for the \circetwo\ structure function ' // &
           'can be selected. (cf. also \ttt{circe2}, \ttt{?circe2\_polarized}, ' // &
           '\ttt{\$circe2\_design})'))
     call var_list%append_string (var_str ("$circe2_design"), var_str ("*"), &
           intrinsic=.true., &
           description=var_str ('String variable that sets the collider ' // &
           'design for the \circetwo\ structure function for photon collider ' // &
           'spectra. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, \ttt{?circe2\_polarized})'))
     call var_list%append_real (var_str ("gaussian_spread1"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Parameter that sets the energy spread ' // &
           '($\sigma$ value) of the first beam for a Gaussian spectrum.  ' // &
           '(cf. \ttt{gaussian})'))
      call var_list%append_real (var_str ("gaussian_spread2"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Ditto, for the second beam.'))
     call var_list%append_string (var_str ("$beam_events_file"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           "name of the external file from which a beamstrahlung's spectrum " // &
           'for lepton colliders as pairs of energy fractions is read in. ' // &
           '(cf. also \ttt{beam\_events}, \ttt{?beam\_events\_warn\_eof})'))
     call var_list%append_log (var_str ("?beam_events_warn_eof"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to ' // &
           'issue a warning when in a simulation the end of an external ' // &
           "file for beamstrahlung's spectra for lepton colliders are reached, " // &
           'and energy fractions from the beginning of the file are reused. ' // &
           '(cf. also \ttt{beam\_events}, \ttt{\$beam\_events\_file})'))
     call var_list%append_log (var_str ("?energy_scan_normalize"), .false., &
           intrinsic=.true., &
           description=var_str ('Normalization flag for the energy scan ' // &
           'structure function: if set the total cross section is normalized ' // &
           'to unity. (cf. also \ttt{energy\_scan})'))
   end subroutine var_list_set_beams_defaults
 
 @ %def var_list_set_beams_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_core_defaults => var_list_set_core_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_core_defaults (var_list, seed)
     class(var_list_t), intent(inout) :: var_list
     integer, intent(in) :: seed
     logical, target, save :: known = .true.     !!! ??????
     real(default), parameter :: real_specimen = 1.
     call var_list_append_log_ptr &
          (var_list, var_str ("?logging"), logging, known, &
          intrinsic=.true., &
          description=var_str ('This logical -- when set to \ttt{false} ' // &
          '-- suppresses writing out a logfile (default: \ttt{whizard.log}) ' // &
          'for the whole \whizard\ run, or when \whizard\ is run with the ' // &
          '\ttt{--no-logging} option, to suppress parts of the logging ' // &
          'when setting it to \ttt{true} again at a later part of the ' // &
          '\sindarin\ input file. Mainly for debugging purposes.  ' // &
          '(cf. also \ttt{?openmp\_logging}, \ttt{?mpi\_logging})'))
     call var_list%append_string (var_str ("$job_id"), &
          intrinsic=.true., &
          description=var_str ('Arbitrary string that can be used for ' // &
          'creating unique names.  The variable is initialized with the ' // &
          'value of the \ttt{job\_id} option on startup. (cf. also ' // &
          '\ttt{\$compile\_workspace}, \ttt{\$run\_id})'))
     call var_list%append_string (var_str ("$compile_workspace"), &
          intrinsic=.true., &
          description=var_str ('If set, create process source code ' // &
          'and process-driver library code in a subdirectory with this ' // &
          'name.  If non-existent, the directory will be created. (cf. ' // &
          'also \ttt{\$job\_id}, \ttt{\$run\_id}, \ttt{\$integrate\_workspace})'))
     call var_list%append_int (var_str ("seed"), seed, &
           intrinsic=.true., &
           description=var_str ('Integer variable \ttt{seed = {\em <num>}} ' // &
           'that allows to set a specific random seed \ttt{num}. If not ' // &
           'set, \whizard\ takes the time from the system clock to determine ' // &
           'the random seed.'))
     call var_list%append_string (var_str ("$model_name"), &
           intrinsic=.true., &
           description=var_str ('This variable makes the locally used physics ' // &
           'model available as a string, e.g. as \ttt{show (\$model\_name)}. ' // &
           'However, the user is not able to change the current model by ' // &
           'setting this variable to a different string. (cf. also \ttt{model}, ' // &
           '\ttt{\$library\_name}, \ttt{printf}, \ttt{show})'))
     call var_list%append_int (var_str ("process_num_id"), &
          intrinsic=.true., &
          description=var_str ('Using the integer \ttt{process\_num\_id ' // &
          '= {\em <int\_var>}} one can set a numerical identifier for processes ' // &
          'within a process library. This can be set either just before ' // &
          'the corresponding \ttt{process} definition or as an optional ' // &
          'local argument of the latter. (cf. also \ttt{process}, ' // &
          '\ttt{?proc\_as\_run\_id}, \ttt{lcio\_run\_id})'))
     call var_list%append_log (var_str ("?proc_as_run_id"), .true., &
          intrinsic=.true., &
          description=var_str ('Normally, for LCIO the process ID (cf. ' // &
          '\ttt{process\_num\_id}) is used as run ID, unless this flag is ' // &
          'set to \ttt{false}, cf. also \ttt{process}, \ttt{lcio\_run\_id}.'))
     call var_list%append_int (var_str ("lcio_run_id"), 0, &
          intrinsic=.true., &
          description=var_str ('Allows to set an integer run ID for the LCIO ' // &
          'event format. Normally, the process ID is taken as run ID, unless ' // &
          'the flag (cf.) \ttt{?proc\_as\_run\_id} is set to \ttt{false}, ' // &
          'cf. also \ttt{process}.'))
     call var_list%append_string (var_str ("$method"), var_str ("omega"), &
          intrinsic=.true., &
          description=var_str ('This string variable specifies the method ' // &
          'for the matrix elements to be used in the evaluation. The default ' // &
          "is the intrinsic \oMega\ matrix element generator " // &
          '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // &
          '\ttt{"template\_unity"}, \ttt{"threshold"}. For processes defined ' // &
          '\ttt{"template"}, with \ttt{nlo\_calculation = ...}, please refer to ' // &
          '\ttt{\$born\_me\_method}, \ttt{\$real\_tree\_me\_method}, ' // &
          '\ttt{\$loop\_me\_method} and \ttt{\$correlation\_me\_method}.'))
     call var_list%append_log (var_str ("?report_progress"), .true., &
          intrinsic=.true., &
          description=var_str ('Flag for the \oMega\ matrix element generator ' // &
          'whether to print out status messages about progress during ' // &
          'matrix element generation. (cf. also \ttt{\$method}, \ttt{\$omega\_flags})'))
     call var_list%append_log (var_str ("?me_verbose"), .false., &
          description=var_str ("Flag determining whether " // &
          "the makefile command for generating and compiling the \oMega\ matrix " // &
          "element code is silent or verbose. Default is silent."))
     call var_list%append_string (var_str ("$restrictions"), var_str (""), &
          intrinsic=.true., &
          description=var_str ('This is an optional argument for process ' // &
          'definitions for the matrix element method \ttt{"omega"}. Using ' // &
          'the following construction, it defines a string variable, \ttt{process ' // &
          '\newline {\em <process\_name>} = {\em <particle1>}, {\em <particle2>} ' // &
          '=> {\em <particle3>}, {\em <particle4>}, ... \{ \$restrictions ' // &
          '= "{\em <restriction\_def>}" \}}. The string argument \ttt{{\em ' // &
          '<restriction\_def>}} is directly transferred during the code ' // &
          'generation to the ME generator \oMega. It has to be of the form ' // &
          '\ttt{n1 + n2 + ...  \url{~} {\em <particle (list)>}}, where ' // &
          '\ttt{n1} and so on are the numbers of the particles above in ' // &
          'the process definition. The tilde specifies a certain intermediate ' // &
          'state to be equal to the particle(s) in \ttt{particle (list)}. ' // &
          'An example is \ttt{process eemm\_z =     e1, E1  =>  e2, E2 ' // &
          '\{ \$restrictions = "1+2 \url{~} Z" \} } restricts the code ' // &
          'to be generated for the process $e^- e^+ \to \mu^- \mu^+$ to ' // &
          'the $s$-channel $Z$-boson exchange. For more details see Sec.~\ref{sec:omega_me} ' // &
          '(cf. also \ttt{process})'))
     call var_list%append_log (var_str ("?omega_write_phs_output"), .false., &
          intrinsic=.true., &
          description=var_str ('This flag decides whether a the phase-space ' // &
          'output is produced by the \oMega\ matrix element generator. This ' // &
          'output is written to file(s) and contains the Feynman diagrams ' // &
          'which belong to the process(es) under consideration. The file is ' // &
          'mandatory whenever the variable \ttt{\$phs\_method} has the value ' // &
          '\ttt{fast\_wood}, i.e. if the phase-space file is provided by ' // &
          'cascades2.'))
     call var_list%append_string (var_str ("$omega_flags"), var_str (""), &
          intrinsic=.true., &
          description=var_str ('String variable that allows to pass flags ' // &
          'to the \oMega\ matrix element generator. Normally, \whizard\ ' // &
          'takes care of all flags automatically. Note that for restrictions ' // &
          'of intermediate states, there is a special string variable: ' // &
          '(cf. $\to$) \ttt{\$restrictions}.'))
     call var_list%append_log (var_str ("?read_color_factors"), .true., &
           intrinsic=.true., &
           description=var_str ('This flag decides whether to read QCD ' // &
           'color factors from the matrix element provided by each method, ' // &
           'or to try and calculate the color factors in \whizard\ internally.'))
     call var_list%append_log (var_str ("?slha_read_input"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag which decides whether \whizard\ reads ' // &
           'in the SM and parameter information from the \ttt{SMINPUTS} ' // &
           'and \ttt{MINPAR} common blocks of the SUSY Les Houches Accord ' // &
           'files. (cf. also \ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, ' // &
           '\ttt{?slha\_read\_decays})'))
     call var_list%append_log (var_str ("?slha_read_spectrum"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag which decides whether \whizard\ reads ' // &
           'in the whole spectrum and mixing angle information from the ' // &
           'common blocks of the SUSY Les Houches Accord files. (cf. also ' // &
           '\ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_decays}, ' // &
           '\ttt{?slha\_read\_input})'))
     call var_list%append_log (var_str ("?slha_read_decays"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag which decides whether \whizard\ reads ' // &
           'in the widths and branching ratios from the \ttt{DCINFO} common ' // &
           'block of the SUSY Les Houches Accord files. (cf. also \ttt{read\_slha}, ' // &
           '\ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, \ttt{?slha\_read\_input})'))
     call var_list%append_string (var_str ("$library_name"), &
           intrinsic=.true., &
           description=var_str ('Similar to \ttt{\$model\_name}, this string ' // &
           'variable is used solely to access the name of the active process ' // &
           'library, e.g. in \ttt{printf} statements. (cf. \ttt{compile}, ' // &
           '\ttt{library}, \ttt{printf}, \ttt{show}, \ttt{\$model\_name})'))
     call var_list%append_log (var_str ("?alphas_is_fixed"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use a non-running ' // &
           '$\alpha_s$. Note that this has to be set explicitly to $\ttt{false}$ ' // &
           'if the user wants to use one of the running $\alpha_s$ options. ' // &
           '(cf. also \ttt{alphas\_order}, \ttt{?alphas\_from\_lhapdf}, ' // &
           '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // &
           '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
     call var_list%append_log (var_str ("?alphas_from_lhapdf"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use a running ' // &
           '$\alpha_s$ from the \lhapdf\ library (which has to be correctly ' // &
           'linked). Note that \ttt{?alphas\_is\_fixed} has to be set ' // &
           'explicitly to $\ttt{false}$. (cf. also \ttt{alphas\_order}, ' // &
           '\ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // &
           '\ttt{lambda\_qcd})'))
     call var_list%append_log (var_str ("?alphas_from_pdf_builtin"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use a running ' // &
           '$\alpha_s$ from the internal PDFs. Note that in that case \ttt{?alphas\_is\_fixed} ' // &
           'has to be set explicitly to $\ttt{false}$. (cf. also ' // &
           '\ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // &
           '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \newline \ttt{?alphas\_from\_lambda\_qcd}, ' // &
           '\ttt{lambda\_qcd})'))
     call var_list%append_int (var_str ("alphas_order"), 0, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that sets the order ' // &
           'of the internal evolution for running $\alpha_s$ in \whizard: ' // &
           'the default, \ttt{0}, is LO running, \ttt{1} is NLO, \ttt{2} ' // &
           'is NNLO. (cf. also \ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // &
           '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // &
           '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
     call var_list%append_int (var_str ("alphas_nf"), 5, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that sets the number ' // &
           'of active quark flavors for the internal evolution for running ' // &
           '$\alpha_s$ in \whizard: the default is \ttt{5}. (cf. also ' // &
           '\ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\ttt{alphas\_order}, \ttt{?alphas\_from\_mz}, \newline ' // &
           '\ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
     call var_list%append_log (var_str ("?alphas_from_mz"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use its internal ' // &
           'running $\alpha_s$ from $\alpha_s(M_Z)$. Note that in that ' // &
           'case \ttt{?alphas\_is\_fixed} has to be set explicitly to ' // &
           '$\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // &
           '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
     call var_list%append_log (var_str ("?alphas_from_lambda_qcd"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use its internal ' // &
           'running $\alpha_s$ from $\alpha_s(\Lambda_{QCD})$. Note that ' // &
           'in that case \ttt{?alphas\_is\_fixed} has  to be set explicitly ' // &
           'to $\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // &
           '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\newline \ttt{?alphas\_from\_mz}, \ttt{lambda\_qcd})'))
     call var_list%append_real (var_str ("lambda_qcd"), 200.e-3_default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the value for ' // &
           '$\Lambda_{QCD}$ used in the internal evolution for running ' // &
           '$\alpha_s$ in \whizard. (cf. also \ttt{alphas\_is\_fixed}, ' // &
           '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, ' // &
           '\newline \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // &
           '\ttt{alphas\_order})'))
     call var_list%append_log (var_str ("?fatal_beam_decay"), .true., &
           intrinsic=.true., &
           description=var_str ('Logical variable that let the user decide ' // &
           'whether the possibility of a beam decay is treated as a fatal ' // &
           'error or only as a warning. An example is a process $b t \to ' // &
           'X$, where the bottom quark as an inital state particle appears ' // &
           'as a possible decay product of the second incoming particle, ' // &
           'the top quark. This might trigger inconsistencies or instabilities ' // &
           'in the phase space set-up.'))
     call var_list%append_log (var_str ("?helicity_selection_active"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether \whizard\ uses ' // &
           'a numerical selection rule for vanishing helicities: if active, ' // &
           'then, if a certain helicity combination yields an absolute ' // &
           '(\oMega) matrix element smaller than a certain threshold ($\to$ ' // &
           '\ttt{helicity\_selection\_threshold}) more often than a certain ' // &
           'cutoff ($\to$ \ttt{helicity\_selection\_cutoff}), it will be dropped.'))
     call var_list%append_real (var_str ("helicity_selection_threshold"), &
           1E10_default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that gives the threshold ' // &
           'for the absolute value of a certain helicity combination of ' // &
           'an (\oMega) amplitude. If a certain number ($\to$ ' // &
           '\ttt{helicity\_selection\_cutoff}) of calls stays below this ' // &
           'threshold, that combination will be dropped from then on. (cf. ' // &
           'also \ttt{?helicity\_selection\_active})'))
     call var_list%append_int (var_str ("helicity_selection_cutoff"), 1000, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that gives the number ' // &
           "a certain helicity combination of an (\oMega) amplitude has " // &
           'to be below a certain threshold ($\to$ \ttt{helicity\_selection\_threshold}) ' // &
           'in order to be dropped from then on. (cf. also \ttt{?helicity\_selection\_active})'))
     call var_list%append_string (var_str ("$rng_method"), var_str ("tao"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           'method for the random number generation. Default is Donald ' // &
           "Knuth' RNG method \ttt{TAO}."))
     call var_list%append_log (var_str ("?vis_diags"), .false., &
           intrinsic=.true., &
           description=var_str ('Logical variable that allows to give out ' // &
           "a Postscript or PDF file for the Feynman diagrams for a \oMega\ " // &
           'process.  (cf. \ttt{?vis\_diags\_color}).'))
     call var_list%append_log (var_str ("?vis_diags_color"), .false., &
           intrinsic=.true., &
           description=var_str ('Same as \ttt{?vis\_diags}, but switches ' // &
           'on color flow instead of Feynman diagram generation. (cf. \ttt{?vis\_diags}).'))
     call var_list%append_log (var_str ("?check_event_file"), .true., &
           intrinsic=.true., &
           description=var_str ('Setting this to false turns off all sanity ' // &
           'checks when reading a raw event file with previously generated ' // &
           'events.  Use this at your own risk; the program may return ' // &
           'wrong results or crash if data do not match. (cf. also \ttt{?check\_grid\_file}, ' // &
           '\ttt{?check\_phs\_file})'))
     call var_list%append_string (var_str ("$event_file_version"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           'format version of the \whizard\ internal binary event format.'))
     call var_list%append_int (var_str ("n_events"), 0, &
           intrinsic=.true., &
           description=var_str ('This specifier \ttt{n\_events = {\em <num>}} ' // &
           'sets the number of events for the event generation of the processes ' // &
           'in the \sindarin\ input files. Note that WHIZARD itself chooses ' // &
           'the number from the \ttt{n\_events} or from the \ttt{luminosity} ' // &
           'specifier, whichever would give the larger number of events. ' // &
           'As this depends on the cross section under consideration, it ' // &
           'might be different for different processes in the process list.  ' // &
           '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
           '\ttt{?unweighted}, \ttt{event\_index\_offset})'))
     call var_list%append_int (var_str ("event_index_offset"), 0, &
           intrinsic=.true., &
           description=var_str ('The value ' // &
           '\ttt{event\_index\_offset = {\em <num>}} ' // &
           'initializes the event counter for a subsequent ' // &
           'event sample.  By default (value 0), the first event ' // &
           'gets index value 1, incrementing by one for each generated event ' // &
           'within a sample.  The event counter is initialized again ' // &
           'for each new sample (i.e., \ttt{integrate} command). ' // &
           'If events are read from file, and the ' // &
           'event file format supports event numbering, the event numbers ' // &
           'will be taken from file instead, and the value of ' // &
           '\ttt{event\_index\_offset} has no effect. ' // &
           '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
           '\ttt{?unweighted}, \ttt{n\_events})'))
     call var_list%append_log (var_str ("?unweighted"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that distinguishes between unweighted ' // &
           'and weighted event generation. (cf. also \ttt{simulate}, \ttt{n\_events}, ' // &
           '\ttt{luminosity}, \ttt{event\_index\_offset})'))
     call var_list%append_real (var_str ("safety_factor"), 1._default, &
           intrinsic=.true., &
           description=var_str ('This real variable \ttt{safety\_factor ' // &
           '= {\em <num>}} reduces the acceptance probability for unweighting.  ' // &
           'If greater than one, excess events become less likely, but ' // &
           'the reweighting efficiency also drops. (cf. \ttt{simulate}, \ttt{?unweighted})'))
     call var_list%append_log (var_str ("?negative_weights"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to allow negative ' // &
           'weights in integration and simulation. (cf. also \ttt{simulate}, ' // &
           '\ttt{?unweighted})'))
     call var_list%append_log (var_str ("?resonance_history"), .false., &
           intrinsic=.true., &
           description=var_str ( &
           'The logical variable \texttt{?resonance\_history ' // &
           '= true/false} specifies whether during a simulation pass, ' // &
           'the event generator should try to reconstruct intermediate ' // &
           'resonances.  If activated, appropriate resonant subprocess ' // &
           'matrix element code will be automatically generated. '))
     call var_list%append_real (var_str ("resonance_on_shell_limit"), &
           4._default, &
           intrinsic=.true., &
           description=var_str ( &
           'The real variable \texttt{resonance\_on\_shell\_limit ' // &
           '= {\em <num>}} specifies the maximum relative distance from a ' // &
           'resonance peak, such that the kinematical configuration ' // &
           'can still be considered on-shell.  This is relevant only if ' // &
           '\texttt{?resonance\_history = true}.'))
     call var_list%append_real (var_str ("resonance_on_shell_turnoff"), &
           0._default, &
           intrinsic=.true., &
           description=var_str ( &
           'The real variable \texttt{resonance\_on\_shell\_turnoff ' // &
           '= {\em <num>}}, if positive, ' // &
           'controls the smooth transition from resonance-like ' // &
           'to background-like events.  The relative strength of a ' // &
           'resonance is reduced by a Gaussian with width given by this ' // &
           'variable.  In any case, events are treated as background-like ' // &
           'when the off-shellness is greater than ' // &
           '\texttt{resonance\_on\_shell\_limit}.  All of this applies ' // &
           'only if \texttt{?resonance\_history = true}.'))
     call var_list%append_real (var_str ("resonance_background_factor"), &
           1._default, &
           intrinsic=.true., &
           description=var_str ( &
           'The real variable \texttt{resonance\_background\_factor} ' // &
           'controls resonance insertion if a resonance ' // &
           'history applies to a particular event.  In determining '// &
           'whether event kinematics qualifies as resonant or non-resonant, ' //&
           'the non-resonant probability is multiplied by this factor ' // &
           'Setting the factor to zero removes the background ' // &
           'configuration as long as the kinematics qualifies as on-shell ' // &
           'as qualified by \texttt{resonance\_on\_shell\_limit}.'))
      call var_list%append_log (var_str ("?keep_beams"), .false., &
           intrinsic=.true., &
           description=var_str ('The logical variable \ttt{?keep\_beams ' // &
           '= true/false} specifies whether beam particles and beam remnants ' // &
           'are included when writing event files.  For example, in order ' // &
           'to read Les Houches accord event files into \pythia, no beam ' // &
           'particles are allowed.'))
     call var_list%append_log (var_str ("?keep_remnants"), .true., &
           intrinsic=.true., &
           description=var_str ('The logical variable \ttt{?keep\_beams ' // &
           '= true/false} is respected only if \ttt{?keep\_beams} is set.  ' // &
           'If \ttt{true}, beam remnants are tagged as outgoing particles ' // &
           'if they have been neither showered nor hadronized, i.e., have ' // &
           'no children.  If \ttt{false}, beam remnants are also included ' // &
           'in the event record, but tagged as unphysical.  Note that for ' // &
           'ISR and/or beamstrahlung spectra, the radiated photons are ' // &
           'considered as beam remnants.'))
     call var_list%append_log (var_str ("?recover_beams"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the beam particles ' // &
           'should be reconstructed when reading event/rescanning files ' // &
           'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // &
           '\newline \ttt{?update\_weight})'))
     call var_list%append_log (var_str ("?update_event"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the events in ' // &
           'an event file should be rebuilt from the hard process when ' // &
           'reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // &
           '\ttt{?recover\_beams}, \ttt{?update\_sqme}, \ttt{?update\_weight})'))
     call var_list%append_log (var_str ("?update_sqme"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whehter the squared ' // &
           'matrix element in an event file should be updated/recalculated ' // &
           'when reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // &
           '\newline \ttt{?recover\_beams}, \ttt{?update\_event}, \ttt{?update\_weight})'))
     call var_list%append_log (var_str ("?update_weight"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the weights ' // &
           'in an event file should be updated/recalculated when reading ' // &
           'event/rescanning files into \whizard. (cf. \ttt{rescan}, \ttt{?recover\_beams}, ' // &
           '\newline \ttt{?update\_event}, \ttt{?update\_sqme})'))
     call var_list%append_log (var_str ("?use_alphas_from_file"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the current ' // &
           '$\alpha_s$ definition should be used when recalculating matrix ' // &
           'elements for events read from file, or the value that is stored ' // &
           'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // &
           '\ttt{?use\_scale\_from\_file})'))
     call var_list%append_log (var_str ("?use_scale_from_file"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the current ' // &
           'energy-scale expression should be used when recalculating matrix ' // &
           'elements for events read from file, or the value that is stored ' // &
           'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // &
           '\ttt{?use\_alphas\_from\_file})'))
     call var_list%append_log (var_str ("?allow_decays"), .true., &
           intrinsic=.true., &
           description=var_str ('Master flag to switch on cascade decays ' // &
           'for final state particles as an event transform. As a default, ' // &
           'it is switched on. (cf. also \ttt{?auto\_decays}, ' // &
           '\ttt{auto\_decays\_multiplicity}, \ttt{?auto\_decays\_radiative}, ' // &
           '\ttt{?decay\_rest\_frame})'))
     call var_list%append_log (var_str ("?auto_decays"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag, particularly as optional argument of the ($\to$) ' // &
           '\ttt{unstable} command, that tells \whizard\ to automatically ' // &
           'determine the decays of that particle up to the final state ' // &
           'multplicity ($\to$) \ttt{auto\_decays\_multiplicity}. Depending ' // &
           'on the flag ($\to$) \ttt{?auto\_decays\_radiative}, radiative ' // &
           'decays will be taken into account or not. (cf. also \ttt{unstable}, ' // &
           '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay})'))
     call var_list%append_int (var_str ("auto_decays_multiplicity"), 2, &
           intrinsic=.true., &
           description=var_str ('Integer parameter, that sets -- ' // &
           'for the ($\to$) \ttt{?auto\_decays} option to let \whizard\ ' // &
           'automatically determine the decays of a particle set as ($\to$) ' // &
           '\ttt{unstable} -- the maximal final state multiplicity that ' // &
           'is taken into account. The default is \ttt{2}. The flag \ttt{?auto\_decays\_radiative} ' // &
           'decides whether radiative decays are taken into account. (cf.\ ' // &
           'also \ttt{unstable}, \ttt{?auto\_decays})'))
     call var_list%append_log (var_str ("?auto_decays_radiative"), .false., &
           intrinsic=.true., &
           description=var_str ("If \whizard's automatic detection " // &
           'of decay channels are switched on ($\to$ \ttt{?auto\_decays} ' // &
           'for the ($\to$) \ttt{unstable} command, this flags decides ' // &
           'whether radiative decays (e.g. containing additional photon(s)/gluon(s)) ' // &
           'are taken into account or not. (cf. also \ttt{unstable}, \ttt{auto\_decays\_multiplicity})'))
     call var_list%append_log (var_str ("?decay_rest_frame"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that allows to force a particle decay ' // &
           'to be simulated in its rest frame.  This simplifies the calculation ' // &
           'for decays as stand-alone processes, but makes the process ' // &
           'unsuitable for use in a decay chain.'))
     call var_list%append_log (var_str ("?isotropic_decay"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that -- in case of using factorized ' // &
           'production and decays using the ($\to$) \ttt{unstable} command ' // &
           '-- tells \whizard\ to switch off spin correlations completely ' // &
           '(isotropic decay). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // &
           '\ttt{decay\_helicity}, \ttt{?diagonal\_decay})'))
     call var_list%append_log (var_str ("?diagonal_decay"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that -- in case of using factorized ' // &
           'production and decays using the ($\to$) \ttt{unstable} command ' // &
           '-- tells \whizard\ instead of full spin correlations to take ' // &
           'only the diagonal entries in the spin-density matrix (i.e. ' // &
           'classical spin correlations). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // &
           '\ttt{decay\_helicity}, \ttt{?isotropic\_decay})'))
     call var_list%append_int (var_str ("decay_helicity"), &
           intrinsic=.true., &
           description=var_str ('If this parameter is given an integer ' // &
           'value, any particle decay triggered by a subsequent \ttt{unstable} ' // &
           'declaration will receive a projection on the given helicity ' // &
           'state for the unstable particle.  (cf. also \ttt{unstable}, ' // &
           '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay}.  The latter ' // &
           'parameters, if true, take precdence over any \ttt{?decay\_helicity} setting.)'))
     call var_list%append_log (var_str ("?polarized_events"), .false., &
             intrinsic=.true., &
             description=var_str ('Flag that allows to select certain helicity ' // &
             'combinations in final state particles in the event files, ' // &
             'and perform analysis on polarized event samples. (cf. also ' // &
             '\ttt{simulate}, \ttt{polarized}, \ttt{unpolarized})'))
     call var_list%append_string (var_str ("$polarization_mode"), &
          var_str ("helicity"), &
          intrinsic=.true., &
          description=var_str ('String variable that specifies the mode in ' // &
          'which the polarization of particles is handled when polarized events ' // &
          'are written out. Possible options are \ttt{"ignore"}, \ttt{"helicity"}, ' // &
          '\ttt{"factorized"}, and \ttt{"correlated"}. For more details cf. the ' // &
          'detailed section.'))
     call var_list%append_log (var_str ("?colorize_subevt"), .false., &
             intrinsic=.true., &
             description=var_str ('Flag that enables color-index tracking ' // &
             'in the subevent (\ttt{subevt}) objects that are used for ' // &
             'internal event analysis.'))
     call var_list%append_real (var_str ("tolerance"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real variable that defines the absolute ' // &
           'tolerance with which the (logical) function \ttt{expect} accepts ' // &
           'equality or inequality: \ttt{tolerance = {\em <num>}}. This ' // &
           'can e.g. be used for cross-section tests and backwards compatibility ' // &
           'checks.  (cf. also \ttt{expect})'))
     call var_list%append_int (var_str ("checkpoint"), 0, &
          intrinsic = .true., &
          description=var_str ('Setting this integer variable to a positive ' // &
          'integer $n$ instructs simulate to print out a progress summary ' // &
          'every $n$ events.'))
     call var_list%append_int (var_str ("event_callback_interval"), 0, &
          intrinsic = .true., &
          description=var_str ('Setting this integer variable to a positive ' // &
          'integer $n$ instructs simulate to print out a progress summary ' // &
          'every $n$ events.'))
     call var_list%append_log (var_str ("?pacify"), .false., &
          intrinsic=.true., &
          description=var_str ('Flag that allows to suppress numerical ' // &
          'noise and give screen and log file output with a lower number ' // &
          'of significant digits. Mainly for debugging purposes. (cf. also ' // &
          '\ttt{?sample\_pacify})'))
     call var_list%append_string (var_str ("$out_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('This character variable allows to specify ' // &
           'the name of the data file to which the histogram and plot data ' // &
           'are written (cf. also \ttt{write\_analysis}, \ttt{open\_out}, ' // &
           '\ttt{close\_out})'))
     call var_list%append_log (var_str ("?out_advance"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that sets advancing in the \ttt{printf} ' // &
           'output commands, i.e. continuous printing with no line feed ' // &
           'etc. (cf. also \ttt{printf})'))
      !!! JRR: WK please check (#542)
 !     call var_list%append_log (var_str ("?out_custom"), .false., &
 !           intrinsic=.true.)
 !     call var_list%append_string (var_str ("$out_comment"), var_str ("# "), &
 !           intrinsic=.true.)
 !     call var_list%append_log (var_str ("?out_header"), .true., &
 !           intrinsic=.true.)
 !     call var_list%append_log (var_str ("?out_yerr"), .true., &
 !           intrinsic=.true.)
 !     call var_list%append_log (var_str ("?out_xerr"), .true., &
 !           intrinsic=.true.)
     call var_list%append_int (var_str ("real_range"), &
          range (real_specimen), intrinsic = .true., locked = .true., &
          description=var_str ('This integer gives the decimal exponent ' // &
          'range of the numeric model for the real float type in use. It cannot ' // &
          'be set by the user. (cf. also \ttt{real\_precision}, ' // &
          '\ttt{real\_epsilon}, \ttt{real\_tiny}).'))
     call var_list%append_int (var_str ("real_precision"), &
          precision (real_specimen), intrinsic = .true., locked = .true., &
          description=var_str ('This integer gives the precision of ' // &
          'the numeric model for the real float type in use. It cannot ' // &
          'be set by the user. (cf. also \ttt{real\_range}, ' // &
          '\ttt{real\_epsilon}, \ttt{real\_tiny}).'))
     call var_list%append_real (var_str ("real_epsilon"), &
          epsilon (real_specimen), intrinsic = .true., locked = .true., &
          description=var_str ('This gives the smallest number $E$ ' // &
          'of the same kind as the float type for which $1 + E > 1$. ' // &
          'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // &
          '\ttt{real\_tiny}, \ttt{real\_precision}).'))
     call var_list%append_real (var_str ("real_tiny"), &
          tiny (real_specimen), intrinsic = .true., locked = .true., &
          description=var_str ('This gives the smallest positive (non-zero) ' // &
          'number in the numeric model for the real float type in use. ' // &
          'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // &
          '\ttt{real\_epsilon}, \ttt{real\_precision}).'))
   end subroutine var_list_set_core_defaults
 
 @ %def var_list_set_core_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_integration_defaults => var_list_set_integration_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_integration_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_string (var_str ("$integration_method"), var_str ("vamp"), &
           intrinsic=.true., &
           description=var_str ('This string variable specifies the method ' // &
           'for performing the multi-dimensional phase-space integration. ' // &
           'The default is the \vamp\ algorithm (\ttt{"vamp"}), other options ' // &
           'are via the numerical midpoint rule (\ttt{"midpoint"}) or an ' // &
           'alternate \vamptwo\ implementation that is MPI-parallelizable ' // &
           '(\ttt{"vamp2"}).'))
     call var_list%append_int (var_str ("threshold_calls"), 10, &
           intrinsic=.true., &
           description=var_str ('This integer variable gives a limit for ' // &
           'the number of calls in a given channel which acts as a lower ' // &
           'threshold for the channel weight. If the number of calls in ' // &
           'that channel falls below this threshold, the weight is not ' // &
           'lowered further but kept at this threshold. (cf. also ' // &
           '\ttt{channel\_weights\_power})'))
     call var_list%append_int (var_str ("min_calls_per_channel"), 10, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that modifies the settings ' // &
           "of the \vamp\ integrator's grid parameters. It sets the minimal " // &
           'number every channel must be called. If the number of calls ' // &
           'from the iterations is too small, \whizard\ will automatically ' // &
           'increase the number of calls. (cf. \ttt{iterations}, \ttt{min\_calls\_per\_bin}, ' // &
           '\ttt{min\_bins}, \ttt{max\_bins})'))
     call var_list%append_int (var_str ("min_calls_per_bin"), 10, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that modifies the settings ' // &
           "of the \vamp\ integrator's grid parameters. It sets the minimal " // &
           'number every bin in an integration dimension must be called. ' // &
           'If the number of calls from the iterations is too small, \whizard\ ' // &
           'will automatically increase the number of calls. (cf. \ttt{iterations}, ' // &
           '\ttt{min\_calls\_per\_channel}, \ttt{min\_bins}, \ttt{max\_bins})'))
     call var_list%append_int (var_str ("min_bins"), 3, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that modifies the settings ' // &
           "of the \vamp\ integrator's grid parameters. It sets the minimal " // &
           'number of bins per integration dimension. (cf. \ttt{iterations}, ' // &
           '\ttt{max\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})'))
     call var_list%append_int (var_str ("max_bins"), 20, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that modifies the settings ' // &
           "of the \vamp\ integrator's grid parameters. It sets the maximal " // &
           'number of bins per integration dimension. (cf. \ttt{iterations}, ' // &
           '\ttt{min\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})'))
     call var_list%append_log (var_str ("?stratified"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that switches between stratified ' // &
           'and importance sampling for the \vamp\ integration method.'))
     call var_list%append_log (var_str ("?use_vamp_equivalences"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether equivalence ' // &
           'relations (symmetries) between different integration channels ' // &
           'are used by the \vamp\ integrator.'))
     call var_list%append_log (var_str ("?vamp_verbose"), .false., &
          intrinsic=.true., &
          description=var_str ('Flag that sets the chattiness of the \vamp\ ' // &
          'integrator. If set, not only errors, but also all warnings and ' // &
          'messages will be written out (not the default). (cf. also \newline ' // &
          '\ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_global\_verbose}, ' // &
          '\ttt{?vamp\_history\_channels}, \newline \ttt{?vamp\_history\_channels\_verbose})'))
     call var_list%append_log (var_str ("?vamp_history_global"), &
          .true., intrinsic=.true., &
          description=var_str ('Flag that decides whether the global history ' // &
          'of the grid adaptation of the \vamp\ integrator are written ' // &
          'into the process logfiles.  (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // &
          '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_history\_channels\_verbose}, ' // &
          '\ttt{?vamp\_verbose})'))
     call var_list%append_log (var_str ("?vamp_history_global_verbose"), &
          .false., intrinsic=.true., &
          description=var_str ('Flag that decides whether the global history ' // &
          'of the grid adaptation of the \vamp\ integrator are written ' // &
          'into the process logfiles in an extended version. Only for debugging ' // &
          'purposes.  (cf. also \ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_channels}, ' // &
          '\ttt{?vamp\_verbose}, \ttt{?vamp\_history\_channels\_verbose})'))
     call var_list%append_log (var_str ("?vamp_history_channels"), &
          .false., intrinsic=.true., &
          description=var_str ('Flag that decides whether the history of ' // &
          'the grid adaptation of the \vamp\ integrator for every single ' // &
          'channel are written into the process logfiles. Only for debugging ' // &
          'purposes.  (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // &
          '\ttt{?vamp\_history\_global}, \ttt{?vamp\_verbose}, \newline ' // &
          '\ttt{?vamp\_history\_channels\_verbose})'))
     call var_list%append_log (var_str ("?vamp_history_channels_verbose"), &
          .false., intrinsic=.true., &
          description=var_str ('Flag that decides whether the history of ' // &
          'the grid adaptation of the \vamp\ integrator for every single ' // &
          'channel are written into the process logfiles in an extended ' // &
          'version. Only for debugging purposes.  (cf. also \ttt{?vamp\_history\_global}, ' // &
          '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_verbose}, \ttt{?vamp\_history\_global\_verbose})'))
     call var_list%append_string (var_str ("$run_id"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable \ttt{\$run\_id = "{\em ' // &
           '<id>}"} that allows to set a special ID for a particular process ' // &
           'run, e.g. in a scan. The run ID is then attached to the process ' // &
           'log file: \newline \ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em ' // &
           '<id>}.log}, the \vamp\ grid file: \newline \ttt{{\em <proc\_name>}\_{\em ' // &
           '<proc\_comp>}.{\em <id>}.vg}, and the phase space file: \newline ' // &
           '\ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em <id>}.phs}. ' // &
           'The run ID string distinguishes among several runs for the ' // &
           'same process.  It identifies process instances with respect ' // &
           'to adapted integration grids and similar run-specific data.  ' // &
           'The run ID is kept when copying processes for creating instances, ' // &
           'however, so it does not distinguish event samples. (cf.\ also ' // &
           '\ttt{\$job\_id}, \ttt{\$compile\_workspace}'))
     call var_list%append_int (var_str ("n_calls_test"), 0, &
           intrinsic=.true., &
           description=var_str ('Integer variable that allows to set a ' // &
           'certain number of matrix element sampling test calls without ' // &
           'actually integrating the process under consideration. (cf. ' // &
           '\ttt{integrate})'))
     call var_list%append_log (var_str ("?integration_timer"), .true., &
           intrinsic=.true., &
           description=var_str ('This flag switches the integration timer ' // &
           'on and off, that gives the estimate for the duration of the ' // &
           'generation of 10,000 unweighted events for each integrated ' // &
           'process.'))
     call var_list%append_log (var_str ("?check_grid_file"), .true., &
           intrinsic=.true., &
           description=var_str ('Setting this to false turns off all sanity ' // &
           'checks when reading a grid file with previous integration data.  ' // &
           'Use this at your own risk; the program may return wrong results ' // &
           'or crash if data do not match. (cf. also \ttt{?check\_event\_file}, \ttt{?check\_phs\_file}) '))
     call var_list%append_real (var_str ("accuracy_goal"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows the user to ' // &
           'set a minimal accuracy that should be achieved in the Monte-Carlo ' // &
           'integration of a certain process. If that goal is reached, ' // &
           'grid and weight adapation stop, and this result is used for ' // &
           'simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
           '\ttt{error\_goal}, \ttt{relative\_error\_goal}, ' // &
           '\ttt{error\_threshold})'))
     call var_list%append_real (var_str ("error_goal"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows the user to ' // &
           'set a minimal absolute error that should be achieved in the ' // &
           'Monte-Carlo integration of a certain process. If that goal ' // &
           'is reached, grid and weight adapation stop, and this result ' // &
           'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
           '\ttt{accuracy\_goal}, \ttt{relative\_error\_goal}, \ttt{error\_threshold})'))
     call var_list%append_real (var_str ("relative_error_goal"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows the user to ' // &
           'set a minimal relative error that should be achieved in the ' // &
           'Monte-Carlo integration of a certain process. If that goal ' // &
           'is reached, grid and weight adaptation stop, and this result ' // &
           'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
           '\ttt{accuracy\_goal}, \ttt{error\_goal}, \ttt{error\_threshold})'))
     call var_list%append_int (var_str ("integration_results_verbosity"), 1, &
           intrinsic=.true., &
           description=var_str ('Integer parameter for the verbosity of ' // &
           'the integration results in the process-specific logfile.'))
     call var_list%append_real (var_str ("error_threshold"), &
          0._default, intrinsic=.true., &
          description=var_str ('The real parameter \ttt{error\_threshold ' // &
          '= {\em <num>}} declares that any error value (in absolute numbers) ' // &
          'smaller than \ttt{{\em <num>}} is to be considered zero. The ' // &
          'units are \ttt{fb} for scatterings and \ttt{GeV} for decays. ' // &
          '(cf. also \ttt{integrate}, \ttt{iterations}, \ttt{accuracy\_goal}, ' // &
          '\ttt{error\_goal}, \ttt{relative\_error\_goal})'))
     call var_list%append_real (var_str ("channel_weights_power"), 0.25_default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows to vary the ' // &
           'exponent of the channel weights for the \vamp\ integrator.'))
     call var_list%append_string (var_str ("$integrate_workspace"), &
           intrinsic=.true., &
           description=var_str ('Character string that tells \whizard\ ' // &
           'the subdirectory where to find the run-specific phase-space ' // &
           'configuration and the \vamp\ and \vamptwo\ grid files. ' // &
           'If undefined (as per default), \whizard\ creates them and ' // &
           'searches for them in the ' // &
           'current directory.  (cf. also  \ttt{\$job\_id}, ' // &
           '\ttt{\$run\_id}, \ttt{\$compile\_workspace})'))
     call var_list%append_string (var_str ("$vamp_grid_format"), var_str ("ascii"), &
          intrinsic=.true., &
          description=var_str ('Character string that tells \whizard\ ' // &
          'the file format for \ttt{vamp2} to use for writing and reading ' // &
          'the configuration for the multi-channel integration setup and the ' // &
          '\vamptwo\ (only) grid data. The values can be \ttt{ascii} for a single ' // &
          'human-readable grid file with ending \ttt{.vg2} or \ttt{binary} for two files, ' // &
          'a human-readable header file with ending \ttt{.vg2} and binary file with ending ' // &
          '\ttt{.vgx2} storing the grid data.' // &
          'The main purpose of the binary format is to perform faster I/O, e.g. for HPC runs.' // &
          '\whizard\ can convert between the different file formats automatically.'))
   end subroutine var_list_set_integration_defaults
 
 @ %def var_list_set_integration_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_phase_space_defaults => var_list_set_phase_space_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_phase_space_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_string (var_str ("$phs_method"), var_str ("default"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to choose ' // &
           'the phase-space parameterization method. The default is the ' // &
           '\ttt{"wood"} method that takes into account electroweak/BSM ' // &
           'resonances. Note that this might not be the best choice for ' // &
           '(pure) QCD amplitudes. (cf. also \ttt{\$phs\_file})'))
     call var_list%append_log (var_str ("?vis_channels"), .false., &
           intrinsic=.true., &
           description=var_str ('Optional logical argument for the \ttt{integrate} ' // &
           'command that demands \whizard\ to generate a PDF or postscript ' // &
           'output showing the classification of the found phase space ' // &
           'channels (if the phase space method \ttt{wood} has been used) ' // &
           'according to their properties: \ttt{integrate (foo) \{ iterations=3:10000 ' // &
           '?vis\_channels = true \}}. The default is \ttt{false}.  (cf. ' // &
           'also \ttt{integrate}, \ttt{?vis\_history})'))
     call var_list%append_log (var_str ("?check_phs_file"), .true., &
           intrinsic=.true., &
           description=var_str ('Setting this to false turns off all sanity ' // &
           'checks when reading a previously generated phase-space configuration ' // &
           'file.  Use this at your own risk; the program may return wrong ' // &
           'results or crash if data do not match. (cf. also \ttt{?check\_event\_file}, ' // &
           '\ttt{?check\_grid\_file})'))
     call var_list%append_string (var_str ("$phs_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('This string variable allows the user to ' // &
           'set an individual file name for the phase space parameterization ' // &
           'for a particular process: \ttt{\$phs\_file = "{\em <file\_name>}"}. ' // &
           'If not set, the default is \ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em ' // &
           '<run\_id>}.phs}. (cf. also \ttt{\$phs\_method})'))
     call var_list%append_log (var_str ("?phs_only"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag (particularly as optional argument ' // &
           'of the $\to$ \ttt{integrate} command) that allows to only generate ' // &
           'the phase space file, but not perform the integration. (cf. ' // &
           'also \ttt{\$phs\_method}, \ttt{\$phs\_file})'))
     call var_list%append_real (var_str ("phs_threshold_s"), 50._default, &
           intrinsic=.true., &
           description=var_str ('For the phase space method \ttt{wood}, ' // &
           'this real parameter sets the threshold below which particles ' // &
           'are assumed to be massless in the $s$-channel like kinematic ' // &
           'regions. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_off\_shell}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // &
           '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
           '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})'))
     call var_list%append_real (var_str ("phs_threshold_t"), 100._default, &
           intrinsic=.true., &
           description=var_str ('For the phase space method \ttt{wood}, ' // &
           'this real parameter sets the threshold below which particles ' // &
           'are assumed to be massless in the $t$-channel like kinematic ' // &
           'regions. (cf. also \ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // &
           '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
           '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})'))
     call var_list%append_int (var_str ("phs_off_shell"), 2, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that sets the number ' // &
           'of off-shell (not $t$-channel-like, non-resonant) lines that ' // &
           'are taken into account to find a valid phase-space setup in ' // &
           'the \ttt{wood} phase-space method.  (cf. also \ttt{phs\_threshold\_t}, ' // &
           '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
           '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // &
           '\ttt{?phs\_s\_mapping})'))
     call var_list%append_int (var_str ("phs_t_channel"), 6, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that sets the number ' // &
           'of $t$-channel propagators in multi-peripheral diagrams that ' // &
           'are taken into account to find a valid phase-space setup in ' // &
           'the \ttt{wood} phase-space method.  (cf. also \ttt{phs\_threshold\_t}, ' // &
           '\ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
           '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // &
           '\ttt{?phs\_s\_mapping})'))
     call var_list%append_real (var_str ("phs_e_scale"), 10._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the energy scale ' // &
           'that acts as a cutoff for parameterizing radiation-like kinematics ' // &
           'in the \ttt{wood} phase space method. \whizard\ takes the maximum ' // &
           'of this value and the width of the propagating particle as ' // &
           'a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // &
           '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
           '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
     call var_list%append_real (var_str ("phs_m_scale"), 10._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the mass scale ' // &
           'that acts as a cutoff for parameterizing collinear and infrared ' // &
           'kinematics in the \ttt{wood} phase space method. \whizard\ ' // &
           'takes the maximum of this value and the mass of the propagating ' // &
           'particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell},  \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
           '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
     call var_list%append_real (var_str ("phs_q_scale"), 10._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the momentum ' // &
           'transfer scale that acts as a cutoff for parameterizing $t$- ' // &
           'and $u$-channel like kinematics in the \ttt{wood} phase space ' // &
           'method. \whizard\ takes the maximum of this value and the mass ' // &
           'of the propagating particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, ' // &
           '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_off\_shell},  ' // &
           '\ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
           '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp}, ' // &
           '\newline \ttt{?phs\_s\_mapping})'))
     call var_list%append_log (var_str ("?phs_keep_nonresonant"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the \ttt{wood} ' // &
           'phase space method takes into account also non-resonant contributions.  ' // &
           '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // &
           '\ttt{phs\_q\_scale}, \ttt{phs\_e\_scale}, \ttt{?phs\_step\_mapping}, ' // &
           '\newline \ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
     call var_list%append_log (var_str ("?phs_step_mapping"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that switches on (or off) a particular ' // &
           'phase space mapping for resonances, where the mass and width ' // &
           'of the resonance are explicitly set as channel cutoffs. (cf. ' // &
           'also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, ' // &
           '\ttt{phs\_off\_shell},  \ttt{phs\_e\_scale}, \newline \ttt{phs\_m\_scale}, ' // &
           '\ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, \ttt{?phs\_step\_mapping\_exp}, ' // &
           '\newline \ttt{?phs\_s\_mapping})'))
     call var_list%append_log (var_str ("?phs_step_mapping_exp"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that switches on (or off) a particular ' // &
           'phase space mapping for resonances, where the mass and width ' // &
           'of the resonance are explicitly set as channel cutoffs. This ' // &
           'is an exponential mapping in contrast to ($\to$) \ttt{?phs\_step\_mapping}. ' // &
           '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell},  \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
           '\ttt{?phs\_step\_mapping}, \ttt{?phs\_s\_mapping})'))
     call var_list%append_log (var_str ("?phs_s_mapping"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that allows special mapping for $s$-channel ' // &
           'resonances.  (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell},  \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, ' // &
           '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp})'))
     call var_list%append_log (var_str ("?vis_history"), .false., &
           intrinsic=.true., &
           description=var_str ('Optional logical argument for the \ttt{integrate} ' // &
           'command that demands \whizard\ to generate a PDF or postscript ' // &
           'output showing the adaptation history of the Monte-Carlo integration ' // &
           'of the process under consideration. (cf. also \ttt{integrate}, ' // &
           '\ttt{?vis\_channels})'))
   end subroutine var_list_set_phase_space_defaults
 
 @ %def var_list_set_phase_space_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_gamelan_defaults => var_list_set_gamelan_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_gamelan_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_int (&
          var_str ("n_bins"), 20, &
          intrinsic=.true., &
          description=var_str ("Settings for \whizard's internal graphics " // &
          'output: integer value that sets the number of bins in histograms. ' // &
          '(cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
          '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
          '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, ' // &
          '\ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, ' // &
          '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
          '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
          '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
          '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
          '\ttt{\$symbol})'))
     call var_list%append_log (&
          var_str ("?normalize_bins"), .false., &
          intrinsic=.true., &
          description=var_str ("Settings for \whizard's internal graphics " // &
          'output: flag that determines whether the weights shall be normalized ' // &
          'to the bin width or not. (cf. also \ttt{n\_bins}, \ttt{\$obs\_label}, ' // &
          '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
          '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
          '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
          '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
          '\newline \ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
          '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \newline ' // &
          '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
          '\ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$obs_label"), var_str (""), &
          intrinsic=.true., &
          description=var_str ("Settings for \whizard's internal graphics " // &
          'output: this is a string variable \ttt{\$obs\_label = "{\em ' // &
          '<LaTeX\_Code>}"} that allows to attach a label to a plotted ' // &
          'or histogrammed observable. (cf. also \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // &
          '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
          '\ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
          '\ttt{graph\_height\_mm}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
          '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
          '\ttt{?draw\_histogram}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
          '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
          '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$obs_unit"), var_str (""), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: this is a string variable \ttt{\$obs\_unit = "{\em ' // &
           '<LaTeX\_Code>}"} that allows to attach a \LaTeX\ physical unit ' // &
           'to a plotted or histogrammed observable. (cf. also \ttt{n\_bins}, ' // &
           '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
           '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$title"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('This string variable sets the title of ' // &
           'a plot in a \whizard\ analysis setup, e.g. a histogram or an ' // &
           'observable. The syntax is \ttt{\$title = "{\em <your title>}"}. ' // &
           'This title appears as a section header in the analysis file, ' // &
           'but not in the screen output of the analysis.  (cf. also \ttt{n\_bins}, ' // &
           '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
           '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \newline \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$description"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to specify ' // &
           'a description text for the analysis, \ttt{\$description = "{\em ' // &
           '<LaTeX analysis descr.>}"}.  This line appears below the title ' // &
           'of a corresponding analysis, on top of the respective plot.  ' // &
           '(cf. also \ttt{analysis}, \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, ' // &
           '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$x_label"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable, \ttt{\$x\_label = "{\em ' // &
           '<LaTeX code>}"}, that sets the $x$ axis label in a plot or ' // &
           'histogram in a \whizard\ analysis.  (cf. also \ttt{analysis}, ' // &
           '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$y\_label}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$y_label"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable, \ttt{\$y\_label = "{\em ' // &
           '<LaTeX\_code>}"}, that sets the $y$ axis label in a plot or ' // &
           'histogram in a \whizard\ analysis.  (cf. also \ttt{analysis}, ' // &
           '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{?y\_log}, ' // &
           '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_int (var_str ("graph_width_mm"), 130, &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: integer value that sets the width of a graph or histogram ' // &
           'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // &
           '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_int (var_str ("graph_height_mm"), 90, &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: integer value that sets the height of a graph or histogram ' // &
           'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // &
           '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_log (var_str ("?y_log"), .false., &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that makes the $y$ axis logarithmic. (cf. also ' // &
           '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
           '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
           '\ttt{\$symbol})'))
     call var_list%append_log (var_str ("?x_log"), .false., &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that makes the $x$ axis logarithmic. (cf. also ' // &
           '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
           '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
           '\ttt{\$symbol})'))
     call var_list%append_real (var_str ("x_min"),  &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: real parameter that sets the lower limit of the $x$ ' // &
           'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_real (var_str ("x_max"),  &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: real parameter that sets the upper limit of the $x$ ' // &
           'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{x\_min}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_real (var_str ("y_min"),  &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: real parameter that sets the lower limit of the $y$ ' // &
           'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{x\_max}, \ttt{y\_max}, \ttt{x\_min}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_real (var_str ("y_max"),  &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: real parameter that sets the upper limit of the $y$ ' // &
           'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{x\_max}, \ttt{x\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$gmlcode_bg"), var_str (""), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: string variable that allows to define a background ' // &
           'for plots and histograms (i.e. it is overwritten by the plot/histogram), ' // &
           'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // &
           'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$gmlcode_fg"), var_str (""), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: string variable that allows to define a foreground ' // &
           'for plots and histograms (i.e. it overwrites the plot/histogram), ' // &
           'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // &
           'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_histogram"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to either plot data as a ' // &
           'histogram or as a continuous line (if $\to$ \ttt{?draw\_curve} ' // &
           'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
           '\ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_base"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to insert a \ttt{base} statement ' // &
           'in the analysis code to calculate the plot data from a data ' // &
           'set. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
           '\ttt{\$symbol}, \newline \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
           '\newline \ttt{\$err\_options})'))
     call var_list%append_log (var_str ("?draw_piecewise"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to data from a data set piecewise, ' // &
           'i.e. histogram style. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit},  \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max},  ' // &
           '\ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg},  ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_base}, \ttt{?fill\_curve}, ' // &
           '\ttt{\$symbol}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options})'))
     call var_list%append_log (var_str ("?fill_curve"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to fill data curves (e.g. ' // &
           'as a histogram). The style can be set with $\to$ \ttt{\$fill\_options ' // &
           '= "{\em <LaTeX\_code>}"}. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_curve"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to either plot data as a ' // &
           'continuous line or as a histogram (if $\to$ \ttt{?draw\_histogram} ' // &
           'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
           '\ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_errors"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that determines whether error bars should be drawn ' // &
           'or not. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\newline \ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_symbols"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that determines whether particular symbols (specified ' // &
           'by $\to$ \ttt{\$symbol = "{\em <LaTeX\_code>}"}) should be ' // &
           'used for plotting data points  (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\ttt{?fill\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
           '\newline \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$fill_options"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: \ttt{\$fill\_options = "{\em <LaTeX\_code>}"} is a ' // &
           'string variable that allows to set fill options when plotting ' // &
           'data as filled curves with the $\to$ \ttt{?fill\_curve} flag. ' // &
           'For more details see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
           '\newline \ttt{?draw\_symbols}, \ttt{?fill\_curve}, \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$draw_options"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: \ttt{\$draw\_options = "{\em <LaTeX\_code>}"} is a ' // &
           'string variable that allows to set specific drawing options ' // &
           'for plots and histograms. For more details see the \gamelan\ ' // &
           'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
           '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
           '\ttt{?draw\_histogram}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$err_options"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: \ttt{\$err\_options = "{\em <LaTeX\_code>}"} is a string ' // &
           'variable that allows to set specific drawing options for errors ' // &
           'in plots and histograms. For more details see the \gamelan\ ' // &
           'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{?draw\_histogram}, \ttt{\$draw\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$symbol"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: \ttt{\$symbol = "{\em <LaTeX\_code>}"} is a string ' // &
           'variable for the symbols that should be used for plotting data ' // &
           'points.  (cf. also \ttt{\$obs\_label}, \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \newline \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
           '\newline \ttt{?draw\_histogram}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \newline \ttt{\$err\_options}, ' // &
           '\ttt{?draw\_symbols})'))
     call var_list%append_log (&
          var_str ("?analysis_file_only"), .false., &
          intrinsic=.true., &
          description=var_str ('Allows to specify that only \LaTeX\ files ' // &
          "for \whizard's graphical analysis are written out, but not processed. " // &
          '(cf. \ttt{compile\_analysis}, \ttt{write\_analysis})'))
   end subroutine var_list_set_gamelan_defaults
 
 @ %def var_list_set_gamelan_defaults
 @ FastJet parameters and friends
 <<Variables: var list: TBP>>=
   procedure :: set_clustering_defaults => var_list_set_clustering_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_clustering_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_int (&
          var_str ("kt_algorithm"), &
          kt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the ' // &
          'interfaced external \fastjet\ package.  (cf. also ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, ' // &
          '\ttt{plugin\_algorithm}, ' // &
          '\newline\ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("cambridge_algorithm"), &
          cambridge_algorithm, intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("antikt_algorithm"), &
          antikt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("genkt_algorithm"), &
          genkt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_for\_passive\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r}), \ttt{jet\_p}'))
     call var_list%append_int (&
          var_str ("cambridge_for_passive_algorithm"), &
          cambridge_for_passive_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_algorithm}, \ttt{plugin\_algorithm}, \newline ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("genkt_for_passive_algorithm"), &
          genkt_for_passive_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("ee_kt_algorithm"), &
          ee_kt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_genkt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("ee_genkt_algorithm"), &
          ee_genkt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_kt\_algorithm}, ' // &
          '\ttt{jet\_r}), \ttt{jet\_p})'))
     call var_list%append_int (&
          var_str ("plugin_algorithm"), &
          plugin_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("undefined_jet_algorithm"), &
          undefined_jet_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('This is just a place holder for any kind of jet ' // &
          'jet algorithm that is not further specified.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r}, \ttt{plugin\_algorithm})'))
     call var_list%append_int (&
          var_str ("jet_algorithm"), undefined_jet_algorithm, &
          intrinsic = .true., &
          description=var_str ('Variable that allows to set the type of ' // &
          'jet algorithm when using the external \fastjet\ library. It ' // &
          'accepts one of the following algorithms: ($\to$) \ttt{kt\_algorithm}, ' // &
          '\newline ($\to$) \ttt{cambridge\_[for\_passive\_]algorithm}, ' // &
          '($\to$) \ttt{antikt\_algorithm}, ($\to$) \ttt{plugin\_algorithm}, ' // &
          '($\to$) \ttt{genkt\_[for\_passive\_]algorithm}, ($\to$) ' // &
          '\ttt{ee\_[gen]kt\_algorithm}).  (cf. also \ttt{cluster}, ' // &
          '\ttt{jet\_p}, \ttt{jet\_r}, \ttt{jet\_ycut})'))
     call var_list%append_real (&
          var_str ("jet_r"), 0._default, &
          intrinsic = .true., &
          description=var_str ('Value for the distance measure $R$ used in ' // &
          'some algorithms that are available via the interface ' // &
          'to the \fastjet\ package.  (cf. also \ttt{cluster}, \ttt{combine}, ' // &
          '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
          '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_ycut})'))
     call var_list%append_real (&
          var_str ("jet_p"), 0._default, &
          intrinsic = .true., &
          description=var_str ('Value for the exponent of the distance measure $R$ in ' // &
          'the generalized $k_T$ algorithms that are available via the interface ' // &
          'to the \fastjet\ package.  (cf. also \ttt{cluster}, \ttt{combine}, ' // &
          '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
          '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r}, \newline\ttt{jet\_ycut})'))
     call var_list%append_real (&
          var_str ("jet_ycut"), 0._default, &
          intrinsic = .true., &
          description=var_str ('Value for the $y$ separation measure used in ' // &
          'the Cambridge-Aachen algorithms that are available via the interface ' // &
          'to the \fastjet\ package.  (cf. also \ttt{cluster}, \ttt{combine}, ' // &
          '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
          '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})'))
     call var_list%append_real (&
          var_str ("jet_dcut"), 0._default, &
          intrinsic = .true., &
          description=var_str ('Value for the $d_{ij}$ separation measure used in ' // &
          'the $e^+e^- k_T$ algorithms that are available via the interface ' // &
          'to the \fastjet\ package.  (cf. also \ttt{cluster}, \ttt{combine}, ' // &
          '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
          '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})'))
     call var_list%append_log (&
          var_str ("?keep_flavors_when_clustering"), .false., &
          intrinsic = .true., &
          description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_clustering ' // &
          '= true/false} specifies whether the flavor of a jet should be ' // &
          'kept during \ttt{cluster} when a jet consists of one quark and ' // &
          'zero or more gluons. Especially useful for cuts on b-tagged ' // &
          'jets (cf. also \ttt{cluster}).'))
   end subroutine var_list_set_clustering_defaults
 
 @ %def var_list_set_clustering_defaults
 @ Frixione isolation parameters and all that:
 <<Variables: var list: TBP>>=
   procedure :: set_isolation_defaults => var_list_set_isolation_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_isolation_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_real (var_str ("photon_iso_eps"), 1._default, &
          intrinsic=.true., &
          description=var_str ('Photon isolation parameter $\epsilon_\gamma$ ' // &
          '(energy fraction) from hep-ph/9801442 (cf. also ' // &
          '\ttt{photon\_iso\_n}, \ttt{photon\_iso\_r0})'))
     call var_list%append_real (var_str ("photon_iso_n"), 1._default, &
          intrinsic=.true., &
          description=var_str ('Photon isolation parameter $n$ ' // &
          '(cone function exponent) from hep-ph/9801442 (cf. also ' // &
          '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_r0})'))
     call var_list%append_real (var_str ("photon_iso_r0"), 0.4_default, &
          intrinsic=.true., &
          description=var_str ('Photon isolation parameter $R_0^\gamma$ ' // &
          '(isolation cone radius) from hep-ph/9801442 (cf. also ' // &
          '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_n})'))
   end subroutine var_list_set_isolation_defaults
 
 @ %def var_list_set_isolation_defaults
 <<Variables: var list: TBP>>=
   procedure :: set_eio_defaults => var_list_set_eio_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_eio_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_string (var_str ("$sample"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable to set the (base) name ' // &
           'of the event output format, e.g. \ttt{\$sample = "foo"} will ' // &
           'result in an intrinsic binary format event file \ttt{foo.evx}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{simulate}, \ttt{hepevt}, ' // &
           '\ttt{ascii}, \ttt{athena}, \ttt{debug}, \ttt{long}, \ttt{short}, ' // &
           '\ttt{hepmc}, \ttt{lhef}, \ttt{lha}, \ttt{stdhep}, \ttt{stdhep\_up}, ' // &
           '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, \ttt{sample\_max\_tries})'))
     call var_list%append_string (var_str ("$sample_normalization"), var_str ("auto"),&
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           'normalization of generated events. There are four options: ' // &
           'option \ttt{"1"} (events normalized to one), \ttt{"1/n"} (sum ' // &
           'of all events in a sample normalized to one), \ttt{"sigma"} ' // &
           '(events normalized to the cross section of the process), and ' // &
           '\ttt{"sigma/n"} (sum of all events normalized to the cross ' // &
           'section). The default is \ttt{"auto"} where unweighted events ' // &
           'are normalized to one, and weighted ones to the cross section. ' // &
           '(cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
           '\ttt{?sample\_pacify}, \ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // &
           '\ttt{sample\_split\_n\_kbytes})'))
     call var_list%append_log (var_str ("?sample_pacify"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag, mainly for debugging purposes: suppresses ' // &
           'numerical noise in the output of a simulation. (cf. also \ttt{simulate}, ' // &
           '\ttt{\$sample}, \ttt{sample\_format}, \ttt{\$sample\_normalization}, ' // &
           '\ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // &
           '\ttt{sample\_split\_n\_kbytes})'))
     call var_list%append_log (var_str ("?sample_select"), .true., &
           intrinsic=.true., &
           description=var_str ('Logical that determines whether a selection should ' // &
           'be applied to the output event format or not. If set to \ttt{false} a ' // &
           'selection is only considered for the evaluation of observables. (cf. ' // &
           '\ttt{select}, \ttt{selection}, \ttt{analysis})'))
     call var_list%append_int (var_str ("sample_max_tries"), 10000, &
          intrinsic = .true., &
          description=var_str ('Integer variable that sets the maximal ' // &
          'number of tries for generating a single event. The event might ' // &
          'be vetoed because of a very low unweighting efficiency, errors ' // &
          'in the event transforms like decays, shower, matching, hadronization ' // &
          'etc. (cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
          '\ttt{?sample\_pacify}, \ttt{\$sample\_normalization}, ' // &
          '\ttt{sample\_split\_n\_evt}, \newline\ttt{sample\_split\_n\_kbytes})'))
     call var_list%append_int (var_str ("sample_split_n_evt"), 0, &
          intrinsic = .true., &
          description=var_str ('When generating events, this integer parameter ' // &
          '\ttt{sample\_split\_n\_evt = {\em <num>}} gives the number \ttt{{\em ' // &
          '<num>}} of breakpoints in the event files, i.e. it splits the ' // &
          'event files into \ttt{{\em <num>} + 1} parts. The parts are ' // &
          'denoted by \ttt{{\em <proc\_name>}.{\em <split\_index>}.{\em ' // &
          '<evt\_extension>}}. Here, \ttt{{\em <split\_index>}} is an integer ' // &
          'running from \ttt{0} to \ttt{{\em <num>}}. The start can be ' // &
          'reset by ($\to$) \ttt{sample\_split\_index}. (cf. also \ttt{simulate}, ' // &
          '\ttt{\$sample}, \ttt{sample\_format}, \ttt{sample\_max\_tries}, ' // &
          '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, ' // &
          '\ttt{sample\_split\_n\_kbytes})'))
     call var_list%append_int (var_str ("sample_split_n_kbytes"), 0, &
          intrinsic = .true., &
          description=var_str ('When generating events, this integer parameter ' // &
          '\ttt{sample\_split\_n\_kbytes = {\em <num>}} limits the file ' // &
          'size of event files.  Whenever an event file has exceeded this ' // &
          'size, counted in kilobytes, the following events will be written ' // &
          'to a new file.  The naming conventions are the same as for ' // &
          '\ttt{sample\_split\_n\_evt}. (cf. also \ttt{simulate}, \ttt{\$sample}, ' // &
          '\ttt{sample\_format}, \ttt{sample\_max\_tries}, \ttt{\$sample\_normalization}, ' // &
          '\ttt{?sample\_pacify})'))
     call var_list%append_int (var_str ("sample_split_index"), 0, &
          intrinsic = .true., &
          description=var_str ('Integer number that gives the starting ' // &
          'index \ttt{sample\_split\_index = {\em <split\_index>}} for ' // &
          'the numbering of event samples \ttt{{\em <proc\_name>}.{\em ' // &
          '<split\_index>}.{\em <evt\_extension>}} split by the \ttt{sample\_split\_n\_evt ' // &
          '= {\em <num>}}. The index runs from \ttt{{\em <split\_index>}} ' // &
          'to \newline \ttt{{\em <split\_index>} + {\em <num>}}. (cf. also \ttt{simulate}, ' // &
          '\ttt{\$sample}, \ttt{sample\_format}, \newline\ttt{\$sample\_normalization}, ' // &
          '\ttt{sample\_max\_tries}, \ttt{?sample\_pacify})'))
     call var_list%append_string (var_str ("$rescan_input_format"), var_str ("raw"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           'event format of the event file that is to be rescanned by the ' // &
           '($\to$) \ttt{rescan} command.'))
     call var_list%append_log (var_str ("?read_raw"), .true., &
           intrinsic=.true., &
           description=var_str ('This flag demands \whizard\ to (try to) ' // &
           'read events (from the internal binary format) first before ' // &
           'generating new ones. (cf. \ttt{simulate}, \ttt{?write\_raw}, ' // &
           '\ttt{\$sample}, \ttt{sample\_format})'))
     call var_list%append_log (var_str ("?write_raw"), .true., &
           intrinsic=.true., &
           description=var_str ("Flag to write out events in \whizard's " // &
           'internal binary format. (cf. \ttt{simulate}, \ttt{?read\_raw}, ' // &
           '\ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_raw"), var_str ("evx"), &
          intrinsic=.true., &
          description=var_str ('String variable that allows via \ttt{\$extension\_raw ' // &
          '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
          "to which events in \whizard's internal format are written. If " // &
          'not set, the default file name and suffix is \ttt{{\em <process\_name>}.evx}. ' // &
          '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_default"), var_str ("evt"), &
          intrinsic=.true., &
          description=var_str ('String variable that allows via \ttt{\$extension\_default ' // &
          '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
          'to which events in a the standard \whizard\ verbose ASCII format ' // &
          'are written. If not set, the default file name and suffix is ' // &
          '\ttt{{\em <process\_name>}.evt}. (cf. also \ttt{sample\_format}, ' // &
          '\ttt{\$sample})'))
     call var_list%append_string (var_str ("$debug_extension"), var_str ("debug"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$debug\_extension ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in a long verbose format with debugging information ' // &
           'are written. If not set, the default file name and suffix is ' // &
           '\ttt{{\em <process\_name>}.debug}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{?debug\_process}, \ttt{?debug\_transforms}, ' // &
           '\ttt{?debug\_decay}, \ttt{?debug\_verbose})'))
     call var_list%append_log (var_str ("?debug_process"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether process information ' // &
           'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // &
           '\ttt{?debug\_decay}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})'))
     call var_list%append_log (var_str ("?debug_transforms"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether information ' // &
           'about event transforms will be displayed in the ASCII debug ' // &
           'event format ($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{?debug\_decay}, \ttt{\$debug\_extension}, ' // &
           '\ttt{?debug\_process}, \ttt{?debug\_verbose})'))
     call var_list%append_log (var_str ("?debug_decay"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether decay information ' // &
           'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // &
           '\ttt{?debug\_process}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})'))
     call var_list%append_log (var_str ("?debug_verbose"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether extensive verbose ' // &
           'information will be included in the ASCII debug event format ' // &
           '($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, \ttt{\$sample}, ' // &
           '\ttt{\$debug\_extension}, \ttt{?debug\_decay}, \ttt{?debug\_transforms}, ' // &
           '\ttt{?debug\_process})'))
     call var_list%append_string (var_str ("$dump_extension"), var_str ("pset.dat"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$dump\_extension ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           "to which events in \whizard's internal particle set format " // &
           'are written. If not set, the default file name and suffix is ' // &
           '\ttt{{\em <process\_name>}.pset.dat}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
           '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
     call var_list%append_log (var_str ("?dump_compressed"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that, if set to \ttt{true}, issues ' // &
           'a very compressed and clear version of the \ttt{dump} ($\to$) ' // &
           'event format. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{\$dump\_extension},  ' // &
           '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
     call var_list%append_log (var_str ("?dump_weights"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that, if set to \ttt{true}, includes ' // &
           'cross sections, weights and excess in the \ttt{dump} ($\to$) ' // &
           'event format. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
           '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_summary})'))
     call var_list%append_log (var_str ("?dump_summary"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that, if set to \ttt{true}, includes ' // &
           'a summary with momentum sums for incoming and outgoing particles ' // &
           'as well as for beam remnants in the \ttt{dump} ($\to$) ' // &
           'event format. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
           '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_weights})'))
     call var_list%append_log (var_str ("?dump_screen"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that, if set to \ttt{true}, outputs ' // &
           'events for the \ttt{dump} ($\to$) event format on screen ' // &
           ' instead of to a file. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
           '\ttt{\$dump\_extension}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
     call var_list%append_log (var_str ("?hepevt_ensure_order"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to ensure that the particle set confirms ' // &
           'the HEPEVT standard. This involves some copying and reordering ' // &
           'to guarantee that mothers and daughters are always next to ' // &
           'each other. Usually this is not necessary.'))
     call var_list%append_string (var_str ("$extension_hepevt"), var_str ("hepevt"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_hepevt ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the \whizard\ version 1 style HEPEVT ASCII ' // &
           'format are written. If not set, the default file name and suffix ' // &
           'is \ttt{{\em <process\_name>}.hepevt}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_ascii_short"), &
           var_str ("short.evt"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_short ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the so called short variant of the \whizard\ ' // &
           'version 1 style HEPEVT ASCII format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.short.evt}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_ascii_long"), &
           var_str ("long.evt"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_long ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the so called long variant of the \whizard\ ' // &
           'version 1 style HEPEVT ASCII format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.long.evt}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_athena"), &
           var_str ("athena.evt"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_athena ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the ATHENA file format are written. If not ' // &
           'set, the default file name and suffix is \ttt{{\em <process\_name>}.athena.evt}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_mokka"), &
            var_str ("mokka.evt"), intrinsic=.true., &
            description=var_str ('String variable that allows via \ttt{\$extension\_mokka ' // &
            '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
            'to which events in the MOKKA format are written. If not set, ' // &
            'the default file name and suffix is \ttt{{\em <process\_name>}.mokka.evt}. ' // &
            '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$lhef_version"), var_str ("2.0"), &
          intrinsic = .true., &
          description=var_str ('Specifier for the Les Houches Accord (LHEF) ' // &
          'event format files with XML headers to discriminate among different ' // &
          'versions of this format.  (cf. also \ttt{\$sample}, \ttt{sample\_format}, ' // &
          '\ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
          '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref}, ' // &
          '\ttt{?lhef\_write\_sqme\_alt})'))
     call var_list%append_string (var_str ("$lhef_extension"), var_str ("lhe"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$lhef\_extension ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the LHEF format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.lhe}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{lhef}, ' // &
           '\ttt{\$lhef\_extension}, \ttt{\$lhef\_version}, \ttt{?lhef\_write\_sqme\_prc}, ' // &
           '\ttt{?lhef\_write\_sqme\_ref}, \ttt{?lhef\_write\_sqme\_alt})'))
     call var_list%append_log (var_str ("?lhef_write_sqme_prc"), .true., &
          intrinsic = .true., &
          description=var_str ('Flag that decides whether in the ($\to$) ' // &
          '\ttt{lhef} event format the weights of the squared matrix element ' // &
          'of the corresponding process shall be written in the LHE file. ' // &
          '(cf. also \ttt{\$sample}, \ttt{sample\_format}, \ttt{lhef}, ' // &
          '\ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, \ttt{?lhef\_write\_sqme\_ref}, ' // &
          '\newline \ttt{?lhef\_write\_sqme\_alt})'))
     call var_list%append_log (var_str ("?lhef_write_sqme_ref"), .false., &
          intrinsic = .true., &
          description=var_str ('Flag that decides whether in the ($\to$) ' // &
          '\ttt{lhef} event format reference weights of the squared matrix ' // &
          'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // &
          '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
          '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_alt})'))
     call var_list%append_log (var_str ("?lhef_write_sqme_alt"), .true., &
          intrinsic = .true., &
          description=var_str ('Flag that decides whether in the ($\to$) ' // &
          '\ttt{lhef} event format alternative weights of the squared matrix ' // &
          'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // &
          '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
          '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref})'))
     call var_list%append_string (var_str ("$extension_lha"), var_str ("lha"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_lha ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the (deprecated) LHA format are written. ' // &
           'If not set, the default file name and suffix is \ttt{{\em <process\_name>}.lha}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_hepmc"), var_str ("hepmc"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_hepmc ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the HepMC format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.hepmc}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_log (var_str ("?hepmc_output_cross_section"), .false., &
          intrinsic = .true., &
          description=var_str ('Flag for the HepMC event format that allows ' // &
          'to write out the cross section (and error) from the integration ' // &
          'together with each HepMC event. This can be used by programs ' // &
          'like Rivet to scale histograms according to the cross section. ' // &
          '(cf.  also \ttt{hepmc})'))
     call var_list%append_string (var_str ("$hepmc3_mode"), var_str ("HepMC3"), &
          intrinsic = .true., &
          description=var_str ('This specifies the writer mode for HepMC3. ' // &
          'Possible values are \ttt{HepMC2}, \ttt{HepMC3} (default),  ' // &
          '\ttt{HepEVT}, \ttt{Root}. and \ttt{RootTree} (cf. also \ttt{hepmc})'))
     call var_list%append_string (var_str ("$extension_lcio"), var_str ("slcio"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_lcio ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the LCIO format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.slcio}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_stdhep"), var_str ("hep"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_stdhep ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the StdHEP format via the HEPEVT common ' // &
           'block are written. If not set, the default file name and suffix ' // &
           'is \ttt{{\em <process\_name>}.hep}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_stdhep_up"), &
           var_str ("up.hep"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_up ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the StdHEP format via the HEPRUP/HEPEUP ' // &
           'common blocks are written. \ttt{{\em <process\_name>}.up.hep} ' // &
           'is the default file name and suffix, if this variable not set. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_stdhep_ev4"), &
           var_str ("ev4.hep"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_ev4 ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the StdHEP format via the HEPEVT/HEPEV4 ' // &
           'common blocks are written. \ttt{{\em <process\_name>}.up.hep} ' // &
           'is the default file name and suffix, if this variable not set. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_hepevt_verb"), &
           var_str ("hepevt.verb"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_hepevt\_verb ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the \whizard\ version 1 style extended or ' // &
           'verbose HEPEVT ASCII format are written. If not set, the default ' // &
           'file name and suffix is \ttt{{\em <process\_name>}.hepevt.verb}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_lha_verb"), &
           var_str ("lha.verb"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_lha\_verb ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the (deprecated) extended or verbose LHA ' // &
           'format are written. If not set, the default file name and suffix ' // &
           'is \ttt{{\em <process\_name>}.lha.verb}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample})'))
   end subroutine var_list_set_eio_defaults
 
 @ %def var_list_set_eio_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_shower_defaults => var_list_set_shower_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_shower_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?allow_shower"), .true., &
          intrinsic=.true., &
          description=var_str ('Master flag to switch on (initial and ' // &
          'final state) parton shower, matching/merging as an event ' // &
          'transform. As a default, it is switched on. (cf. also \ttt{?ps\_ ' // &
          '....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_fsr_active"), .false., &
          intrinsic=.true., &
          description=var_str ('Flag that switches final-state QCD radiation ' // &
          '(FSR) on.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // &
          '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_isr_active"), .false., &
          intrinsic=.true., &
          description=var_str ('Flag that switches initial-state QCD ' // &
          'radiation (ISR) on.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
          '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_taudec_active"), .false., &
             intrinsic=.true., &
             description=var_str ('Flag to switch on $\tau$ decays, at ' // &
             'the moment only via the included external package \ttt{TAUOLA} ' // &
             'and \ttt{PHOTOS}.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
             '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?muli_active"), .false., &
             intrinsic=.true., &
             description=var_str ("Master flag that switches on \whizard's " // &
             'module for multiple interaction with interleaved QCD parton ' // &
             'showers for hadron colliders. Note that this feature is still ' // &
             'experimental. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
             '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})'))
     call var_list%append_string (var_str ("$shower_method"), var_str ("WHIZARD"), &
             intrinsic=.true., &
             description=var_str ('String variable that allows to specify ' // &
             'which parton shower is being used, the default, \ttt{"WHIZARD"}, ' // &
             'is one of the in-house showers of \whizard. Other possibilities ' // &
             'at the moment are only \ttt{"PYTHIA6"}.'))
     call var_list%append_log (var_str ("?shower_verbose"), .false., &
             intrinsic=.true., &
             description=var_str ('Flag to switch on verbose messages when ' // &
             'using shower and/or hadronization. (cf. also \ttt{?allow\_shower}, ' // &
             '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...},'))
     call var_list%append_string (var_str ("$ps_PYTHIA_PYGIVE"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to pass options ' // &
           'for tunes etc. to the attached \pythia\ parton shower or hadronization, ' // &
           'e.g.: \ttt{\$ps\_PYTHIA\_PYGIVE = "MSTJ(41)=1"}.  (cf. also ' // &
           '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
           '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_string (var_str ("$ps_PYTHIA8_config"), var_str (""), &
          intrinsic=.true., &
          description=var_str ('String variable that allows to pass options ' // &
          'for tunes etc. to the attached \pythia\ttt{8} parton shower or hadronization, ' // &
          'e.g.: \ttt{\$ps\_PYTHIA8\_config = "PartonLevel:MPI = off"}.  (cf. also ' // &
          '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_string (var_str ("$ps_PYTHIA8_config_file"), var_str (""), &
          intrinsic=.true., &
          description=var_str ('String variable that allows to pass a filename to a ' // &
          '\pythia\ttt{8} configuration file.'))
     call var_list%append_real (&
          var_str ("ps_mass_cutoff"), 1._default, intrinsic = .true., &
          description=var_str ('Real value that sets the QCD parton shower ' // &
          'lower cutoff scale, where hadronization sets in. (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (&
          var_str ("ps_fsr_lambda"), 0.29_default, intrinsic = .true., &
          description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // &
          'used in running $\alpha_s$ for time-like showers is set (except ' // &
          'for showers in the decay of a resonance). (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (&
          var_str ("ps_isr_lambda"), 0.29_default, intrinsic = .true., &
          description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // &
          'used in running $\alpha_s$ for space-like showers is set. (cf. ' // &
          'also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, ' // &
          '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_int (&
          var_str ("ps_max_n_flavors"), 5, intrinsic = .true., &
          description=var_str ('This integer parameter sets the maxmimum ' // &
          'number of flavors that can be produced in a QCD shower $g\to ' // &
          'q\bar q$. It is also used as the maximal number of active flavors ' // &
          'for the running of $\alpha_s$ in the shower (with a minimum ' // &
          'of 3). (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_isr_alphas_running"), .true., &
             intrinsic=.true., &
             description=var_str ('Flag that decides whether a running ' // &
             '$\alpha_s$ is taken in space-like QCD parton showers. (cf. ' // &
             'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
             '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_fsr_alphas_running"), .true., &
             intrinsic=.true., &
             description=var_str ('Flag that decides whether a running ' // &
             '$\alpha_s$ is taken in time-like QCD parton showers. (cf. ' // &
             'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
             '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str ("ps_fixed_alphas"), &
          0._default, intrinsic = .true., &
          description=var_str ('This real parameter sets the value of $\alpha_s$ ' // &
          'if it is (cf. $\to$ \ttt{?ps\_isr\_alphas\_running}, \newline ' // &
          '\ttt{?ps\_fsr\_alphas\_running}) not running in initial and/or ' // &
          'final-state QCD showers.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
          '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_isr_pt_ordered"), .false., &
             intrinsic=.true., &
             description=var_str ('By this flag, it can be switched between ' // &
             'the analytic QCD ISR shower (\ttt{false}, default) and the ' // &
             '$p_T$ ISR QCD shower (\ttt{true}). (cf. also \ttt{?allow\_shower}, ' // &
             '\ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_isr_angular_ordered"), .true., &
             intrinsic=.true., &
             description=var_str ('If switched one, this flag forces opening ' // &
             'angles of emitted partons in the QCD ISR shower to be strictly ' // &
             'ordered, i.e. increasing towards the hard interaction.  (cf. ' // &
             'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
             '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("ps_isr_primordial_kt_width"), 0._default, intrinsic = .true., &
          description=var_str ('This real parameter sets the width $\sigma ' // &
          '= \braket{k_T^2}$ for the Gaussian primordial $k_T$ distribution ' // &
          'inside the hadron, given by: $\exp[-k_T^2/\sigma^2] k_T dk_T$.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("ps_isr_primordial_kt_cutoff"), 5._default, intrinsic = .true., &
          description=var_str ('Real parameter that sets the upper cutoff ' // &
          'for the primordial $k_T$ distribution inside a hadron.  (cf. ' // &
          'also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, ' // &
          '\ttt{?hadronization\_active}, \ttt{?mlm\_ ...})'))
     call var_list%append_real (var_str &
          ("ps_isr_z_cutoff"), 0.999_default, intrinsic = .true., &
          description=var_str ('This real parameter allows to set the upper ' // &
          'cutoff on the splitting variable $z$ in space-like QCD parton ' // &
          'showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, ' // &
          '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("ps_isr_minenergy"), 1._default, intrinsic = .true., &
          description=var_str ('By this real parameter, the minimal effective ' // &
          'energy (in the c.m. frame) of a time-like or on-shell-emitted ' // &
          'parton in a space-like QCD shower is set. For a hard subprocess ' // &
          'that is not in the rest frame, this number is roughly reduced ' // &
          'by a boost factor $1/\gamma$ to the rest frame of the hard scattering ' // &
          'process.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, ' // &
          '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("ps_isr_tscalefactor"), 1._default, intrinsic = .true., &
          description=var_str ('The $Q^2$ scale of the hard scattering ' // &
          'process is multiplied by this real factor to define the maximum ' // &
          'parton virtuality allowed in time-like QCD showers. This does ' // &
          'only apply to $t$- and $u$-channels, while for $s$-channel resonances ' // &
          'the maximum virtuality is set by $m^2$.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str &
          ("?ps_isr_only_onshell_emitted_partons"), .false., intrinsic=.true., &
          description=var_str ('This flag if set true sets all emitted ' // &
          'partons off space-like showers on-shell, i.e. it would not allow ' // &
          'associated time-like showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
   end subroutine var_list_set_shower_defaults
 
 @ %def var_list_set_shower_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_hadronization_defaults => var_list_set_hadronization_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_hadronization_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log &
          (var_str ("?allow_hadronization"), .true., intrinsic=.true., &
          description=var_str ('Master flag to switch on hadronization ' // &
          'as an event transform. As a default, it is switched on. (cf. ' // &
          'also \ttt{?ps\_ ....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, ' // &
          '\ttt{?hadronization\_active})'))
     call var_list%append_log &
          (var_str ("?hadronization_active"), .false., intrinsic=.true., &
          description=var_str ('Master flag to switch hadronization (through ' // &
          'the attached \pythia\ package) on or off. As a default, it is ' // &
          'off. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...})'))
     call var_list%append_string &
          (var_str ("$hadronization_method"), var_str ("PYTHIA6"), intrinsic = .true., &
          description=var_str ("Determines whether \whizard's own " // &
          "hadronization or the (internally included) \pythiasix\ should be used."))
     call var_list%append_real &
          (var_str ("hadron_enhanced_fraction"), 0.01_default, intrinsic = .true., &
          description=var_str ('Fraction of Lund strings that break with enhanced ' // &
          'width. [not yet active]'))
     call var_list%append_real &
          (var_str ("hadron_enhanced_width"), 2.0_default, intrinsic = .true., &
          description=var_str ('Enhancement factor for the width of breaking ' // &
          'Lund strings. [not yet active]'))
   end subroutine var_list_set_hadronization_defaults
 
 @ %def var_list_set_hadronization_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_tauola_defaults => var_list_set_tauola_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_tauola_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (&
          var_str ("?ps_tauola_photos"), .false., intrinsic=.true., &
          description=var_str ('Flag to switch on \ttt{PHOTOS} for photon ' // &
          'showering inside the \ttt{TAUOLA} package.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_log (&
          var_str ("?ps_tauola_transverse"), .false., intrinsic=.true., &
          description=var_str ('Flag to switch transverse $\tau$ polarization ' // &
          'on or off for Higgs decays into $\tau$ leptons.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_log (&
          var_str ("?ps_tauola_dec_rad_cor"), .true., intrinsic=.true., &
          description=var_str ('Flag to switch radiative corrections for ' // &
          '$\tau$ decays in \ttt{TAUOLA} on or off.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_int (&
          var_str ("ps_tauola_dec_mode1"), 0, intrinsic = .true., &
          description=var_str ('Integer code to request a specific $\tau$ ' // &
          'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // &
          'in correlated decays -- for the second $\tau$. For more information ' // &
          'cf. the comments in the code or the \ttt{TAUOLA} manual.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_int (&
          var_str ("ps_tauola_dec_mode2"), 0, intrinsic = .true., &
          description=var_str ('Integer code to request a specific $\tau$ ' // &
          'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // &
          'in correlated decays -- for the second $\tau$. For more information ' // &
          'cf. the comments in the code or the \ttt{TAUOLA} manual.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_real (&
          var_str ("ps_tauola_mh"), 125._default, intrinsic = .true., &
          description=var_str ('Real option to set the Higgs mass for Higgs ' // &
          'decays into $\tau$ leptons in the interface to \ttt{TAUOLA}.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_real (&
          var_str ("ps_tauola_mix_angle"), 90._default, intrinsic = .true., &
          description=var_str ('Option to set the mixing angle between ' // &
          'scalar and pseudoscalar Higgs bosons for Higgs decays into $\tau$ ' // &
          'leptons in the interface to \ttt{TAUOLA}.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_log (&
          var_str ("?ps_tauola_pol_vector"), .false., intrinsic = .true., &
          description=var_str ('Flag to decide whether for transverse $\tau$ ' // &
          'polarization, polarization information should be taken from ' // &
          '\ttt{TAUOLA} or not.  The default is just based on random numbers.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
   end subroutine var_list_set_tauola_defaults
 
 @ %def var_list_set_tauola_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_mlm_matching_defaults => var_list_set_mlm_matching_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_mlm_matching_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?mlm_matching"), .false., &
             intrinsic=.true., &
             description=var_str ('Master flag to switch on MLM (LO) jet ' // &
             'matching between hard matrix elements and the QCD parton ' // &
             'shower. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // &
             '\ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Qcut_ME"), 0._default, intrinsic = .true., &
          description=var_str ('Real parameter that in the MLM jet matching ' // &
          'between hard matrix elements and QCD parton shower sets a possible ' // &
          'virtuality cut on jets from the hard matrix element. (cf. also ' // &
          '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // &
          '...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Qcut_PS"), 0._default, intrinsic = .true., &
          description=var_str ('Real parameter that in the MLM jet matching ' // &
          'between hard matrix elements and QCD parton shower sets a possible ' // &
          'virtuality cut on jets from the parton shower. (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_ptmin"), 0._default, intrinsic = .true., &
          description=var_str ('This real parameter sets a minimal $p_T$ ' // &
          'that enters the $y_{cut}$ jet clustering measure in the MLM ' // &
          'jet matching between hard matrix elements and QCD parton showers.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_etamax"), 0._default, intrinsic = .true., &
          description=var_str ('This real parameter sets a maximal pseudorapidity ' // &
          'that enters the MLM jet matching between hard matrix elements ' // &
          'and QCD parton showers.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
          '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Rmin"), 0._default, intrinsic = .true., &
          description=var_str ('Real parameter that sets a minimal $R$ ' // &
          'distance value that enters the $y_{cut}$ jet clustering measure ' // &
          'in the MLM jet matching between hard matrix elements and QCD ' // &
          'parton showers.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
          '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Emin"), 0._default, intrinsic = .true., &
          description=var_str ('Real parameter that sets a minimal energy ' // &
          '$E_{min}$ value as an infrared cutoff in the MLM jet matching ' // &
          'between hard matrix elements and QCD parton showers.  (cf. also ' // &
          '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // &
          '...}, \ttt{?hadronization\_active})'))
     call var_list%append_int (var_str &
          ("mlm_nmaxMEjets"), 0, intrinsic = .true., &
          description=var_str ('This integer sets the maximal number of ' // &
          'jets that are available from hard matrix elements in the MLM ' // &
          'jet matching between hard matrix elements and QCD parton shower. ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_ETclusfactor"), 0.2_default, intrinsic = .true., &
          description=var_str ('This real parameter is a factor that enters ' // &
          'the calculation of the $y_{cut}$ measure for jet clustering ' // &
          'after the parton shower in the MLM jet matching between hard ' // &
          'matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_ETclusminE"), 5._default, intrinsic = .true., &
          description=var_str ('This real parameter is a minimal energy ' // &
          'that enters the calculation of the $y_{cut}$ measure for jet ' // &
          'clustering after the parton shower in the MLM jet matching between ' // &
          'hard matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_etaclusfactor"), 1._default, intrinsic = .true., &
          description=var_str ('This real parameter is a factor that enters ' // &
          'the calculation of the $y_{cut}$ measure for jet clustering ' // &
          'after the parton shower in the MLM jet matching between hard ' // &
          'matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Rclusfactor"), 1._default, intrinsic = .true., &
          description=var_str ('This real parameter is a factor that enters ' // &
          'the calculation of the $y_{cut}$ measure for jet clustering ' // &
          'after the parton shower in the MLM jet matching between hard ' // &
          'matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Eclusfactor"), 1._default, intrinsic = .true., &
          description=var_str ('This real parameter is a factor that enters ' // &
          'the calculation of the $y_{cut}$ measure for jet clustering ' // &
          'after the parton shower in the MLM jet matching between hard ' // &
          'matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
 
   end subroutine var_list_set_mlm_matching_defaults
 
 @ %def var_list_set_mlm_matching_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_powheg_matching_defaults => &
        var_list_set_powheg_matching_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_powheg_matching_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?powheg_matching"), &
          .false., intrinsic = .true., &
          description=var_str ('Activates Powheg matching. Needs to be ' // &
          'combined with the \ttt{?combined\_nlo\_integration}-method.'))
     call var_list%append_log (var_str ("?powheg_use_singular_jacobian"), &
          .false., intrinsic = .true., &
          description=var_str ('This allows to give a different ' // &
          'normalization of the Jacobian, resulting in an alternative ' // &
          'POWHEG damping in the singular regions.'))
     call var_list%append_int (var_str ("powheg_grid_size_xi"), &
          5, intrinsic = .true., &
          description=var_str ('Number of $\xi$ points in the POWHEG grid.'))
     call var_list%append_int (var_str ("powheg_grid_size_y"), &
          5, intrinsic = .true., &
          description=var_str ('Number of $y$ points in the POWHEG grid.'))
     call var_list%append_int (var_str ("powheg_grid_sampling_points"), &
          500000, intrinsic = .true., &
          description=var_str ('Number of calls used to initialize the ' // &
          'POWHEG grid.'))
     call var_list%append_real (var_str ("powheg_pt_min"), &
           1._default, intrinsic = .true., &
           description=var_str ('Lower $p_T$-cut-off for the POWHEG ' // &
           'hardest emission.'))
     call var_list%append_real (var_str ("powheg_lambda"), &
           LAMBDA_QCD_REF, intrinsic = .true., &
           description=var_str ('Reference scale of the $\alpha_s$ evolution ' // &
           'in the POWHEG matching algorithm.'))
     call var_list%append_log (var_str ("?powheg_test_sudakov"), &
           .false., intrinsic = .true., &
           description=var_str ('Performs an internal consistency check ' // &
           'on the POWHEG event generation.'))
     call var_list%append_log (var_str ("?powheg_disable_sudakov"), &
           .false., intrinsic = .true., &
           description=var_str ('This flag allows to set the Sudakov form ' // &
           'factor to one. This effectively results in a version of ' // &
           'the matrix-element method (MEM) at NLO.'))
   end subroutine var_list_set_powheg_matching_defaults
 
 @ %def var_list_set_powheg_matching_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_openmp_defaults => var_list_set_openmp_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_openmp_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?omega_openmp"), &
          openmp_is_active (), &
          intrinsic=.true., &
          description=var_str ('Flag to switch on or off OpenMP multi-threading ' // &
          "for \oMega\ matrix elements. (cf. also \ttt{\$method}, \ttt{\$omega\_flag})"))
     call var_list%append_log (var_str ("?openmp_is_active"), &
          openmp_is_active (), &
          locked=.true., intrinsic=.true., &
          description=var_str ('Flag to switch on or off OpenMP multi-threading ' // &
          'for \whizard. (cf. also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, ' // &
          '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})'))
     call var_list%append_int (var_str ("openmp_num_threads_default"), &
          openmp_get_default_max_threads (), &
          locked=.true., intrinsic=.true., &
          description=var_str ('Integer parameter that shows the number ' // &
          'of default OpenMP threads for multi-threading. Note that this ' // &
          'parameter can only be accessed, but not reset by the user. (cf. ' // &
          'also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, \ttt{?omega\_openmp})'))
     call var_list%append_int (var_str ("openmp_num_threads"), &
          openmp_get_max_threads (), &
          intrinsic=.true., &
          description=var_str ('Integer parameter that sets the number ' // &
          'of OpenMP threads for multi-threading.  (cf. also \ttt{?openmp\_logging}, ' // &
          '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})'))
     call var_list%append_log (var_str ("?openmp_logging"), &
          .true., intrinsic=.true., &
          description=var_str ('This logical -- when set to \ttt{false} ' // &
          '-- suppresses writing out messages about OpenMP parallelization ' // &
          '(number of used threads etc.) on screen and into the logfile ' // &
          '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // &
          'Mainly for debugging purposes.  (cf. also \ttt{?logging}, ' // &
          '\ttt{?mpi\_logging})'))
   end subroutine var_list_set_openmp_defaults
 
 @ %def var_list_set_openmp_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_mpi_defaults => var_list_set_mpi_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_mpi_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?mpi_logging"), &
          .false., intrinsic=.true., &
          description=var_str('This logical -- when set to \ttt{false} ' // &
          '-- suppresses writing out messages about MPI parallelization ' // &
          '(number of used workers etc.) on screen and into the logfile ' // &
          '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // &
          'Mainly for debugging purposes.  (cf. also \ttt{?logging}, ' // &
          '\ttt{?openmp\_logging})'))
   end subroutine var_list_set_mpi_defaults
 
 @ %def var_list_set_mpi_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_nlo_defaults => var_list_set_nlo_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_nlo_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_string (var_str ("$born_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ("This string variable specifies the method " // &
          "for the matrix elements to be used in the evaluation of the " // &
          "Born part of the NLO computation. The default is the empty string, " // &
          "i.e. the \ttt{\$method} being the intrinsic \oMega\ matrix element " // &
          'generator (\ttt{"omega"}), other options ' // &
          'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, ' // &
          '\ttt{"template\_unity"}, \ttt{"threshold"}, \ttt{"gosam"}, ' // &
          '\ttt{"openloops"}. Note that this option is inoperative if ' // &
          'no NLO calculation is specified in the process definition. ' // &
          'If you want ot use different matrix element methods in a LO ' // &
          'computation, use the usual \ttt{method} command. (cf. also ' // &
          '\ttt{\$correlation\_me\_method}, ' // &
          '\ttt{\$dglap\_me\_method}, \ttt{\$loop\_me\_method} and ' // &
          '\ttt{\$real\_tree\_me\_method}.)'))
     call var_list%append_string (var_str ("$loop_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('This string variable specifies the method ' // &
          'for the matrix elements to be used in the evaluation of the ' // &
          'virtual part of the NLO computation. The default is the empty string, ' // &
          'i.e. the same as \ttt{\$method}. Working options are: ' // &
          '\ttt{"threshold"}, \ttt{"openloops"}, \ttt{"recola"}, \ttt{"gosam"}. ' // &
          '(cf. also \ttt{\$real\_tree\_me\_method}, \ttt{\$correlation\_me\_method} ' // &
          'and \ttt{\$born\_me\_method}.)'))
     call var_list%append_string (var_str ("$correlation_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('This string variable specifies ' // &
          'the method for the matrix elements to be used in the evaluation ' // &
          'of the color (and helicity) correlated part of the NLO computation. ' // &
          "The default is the same as the \ttt{\$method}, i.e. the intrinsic " // &
          "\oMega\ matrix element generator " // &
          '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // &
          '\ttt{"template"}, \ttt{"template\_unity"}, \ttt{"threshold"}, ' // &
          '\ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // &
          '\ttt{\$born\_me\_method}, \ttt{\$dglap\_me\_method}, ' // &
          '\ttt{\$loop\_me\_method} and \newline' // &
          '\ttt{\$real\_tree\_me\_method}.)'))
     call var_list%append_string (var_str ("$real_tree_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('This string variable specifies the method ' // &
          'for the matrix elements to be used in the evaluation of the ' // &
          'real part of the NLO computation. The default is the same as ' // &
          'the \ttt{\$method}, i.e. the intrinsic ' // &
          "\oMega\ matrix element generator " // &
          '(\ttt{"omega"}), other options ' // &
          'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // &
          '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // &
          '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // &
          '\ttt{\$dglap\_me\_method} and \ttt{\$loop\_me\_method}.)'))
     call var_list%append_string (var_str ("$dglap_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('This string variable specifies the method ' // &
          'for the matrix elements to be used in the evaluation of the ' // &
          'DGLAP remnants of the NLO computation. The default is the same as ' // &
          "\ttt{\$method}, i.e. the \oMega\ matrix element generator " // &
          '(\ttt{"omega"}), other options ' // &
          'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // &
          '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also \newline' // &
          '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // &
          '\ttt{\$loop\_me\_method} and \ttt{\$real\_tree\_me\_method}.)'))
     call var_list%append_log (&
          var_str ("?test_soft_limit"), .false., intrinsic = .true., &
          description=var_str ('Sets the fixed values $\tilde{\xi} = 0.00001$ ' // &
          'and $y = 0.5$ as radiation variables.  This way, only soft, ' // &
          'but non-collinear phase space points are generated, which allows ' // &
          'for testing subtraction in this region.'))
     call var_list%append_log (&
          var_str ("?test_coll_limit"), .false., intrinsic = .true., &
          description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // &
          'and $y = 0.9999999$ as radiation variables.  This way, only collinear, ' // &
          'but non-soft phase space points are generated, which allows ' // &
          'for testing subtraction in this region. Can be combined with ' // &
          '\ttt{?test\_soft\_limit} to probe soft-collinear regions.'))
     call var_list%append_log (&
          var_str ("?test_anti_coll_limit"), .false., intrinsic = .true., &
          description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // &
          'and $y = -0.9999999$ as radiation variables.  This way, only anti-collinear, ' // &
          'but non-soft phase space points are generated, which allows ' // &
          'for testing subtraction in this region. Can be combined with ' // &
          '\ttt{?test\_soft\_limit} to probe soft-collinear regions.'))
     call var_list%append_string (var_str ("$select_alpha_regions"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('Fixes the $\alpha_r$ in the real ' // &
          ' subtraction component. Allows for testing in one individual ' // &
          'singular region.'))
     call var_list%append_string (var_str ("$virtual_selection"), &
          var_str ("Full"), intrinsic = .true., &
          description=var_str ('String variable to select either the full ' // &
          'or only parts of the virtual components of an NLO calculation. ' // &
          'Possible modes are \ttt{"Full"}, \ttt{"OLP"} and ' // &
          '\ttt{"Subtraction."}. Mainly for debugging purposes.'))
     call var_list%append_log (var_str ("?virtual_collinear_resonance_aware"), &
          .true., intrinsic = .true., &
          description=var_str ('This flag allows to switch between two ' // &
          'different implementations of the collinear subtraction in the ' // &
          'resonance-aware FKS setup.'))
     call var_list%append_real (&
          var_str ("blha_top_yukawa"), -1._default, intrinsic = .true., &
          description=var_str ('If this value is set, the given value will ' // &
          'be used as the top Yukawa coupling instead of the top mass. ' // &
          'Note that having different values for $y_t$ and $m_t$ must be ' // &
          'supported by your OLP-library and yield errors if this is not the case.'))
     call var_list%append_string (var_str ("$blha_ew_scheme"), &
          var_str ("alpha_internal"), intrinsic = .true., &
          description=var_str ('String variable that transfers the electroweak ' // &
          'renormalization scheme via BLHA to the one-loop provider. Possible ' // &
          'values are \ttt{GF} or \ttt{Gmu} for the $G_\mu$ scheme, ' // &
          '\ttt{alpha\_internal} (default, $G_\mu$ scheme, but value of ' // &
          '$\alpha_S$ calculated internally by \whizard), \ttt{alpha\_mz} ' // &
          'and \ttt{alpha\_0} (or \ttt{alpha\_thompson}) for different schemes ' // &
          'with $\alpha$ as input.'))
     call var_list%append_int (var_str ("openloops_verbosity"), 1, &
          intrinsic = .true., &
          description=var_str ('Decides how much \openloops\ output is printed. ' // &
          'Can have values 0, 1 and 2, where 2 is the highest verbosity level.'))
     call var_list%append_log (var_str ("?openloops_use_cms"), &
          .true., intrinsic = .true., &
          description=var_str ('Activates the complex mass scheme in ' // &
          '\openloops. (cf. also ' // &
          '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
          '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // &
          '\ttt{openloops\_stability\_log}, \newline' // &
          '\ttt{\$openloops\_extra\_cmd})'))
     call var_list%append_int (var_str ("openloops_phs_tolerance"), 7, &
          intrinsic = .true., &
          description=var_str ('This integer parameter gives via ' // &
          '\ttt{openloops\_phs\_tolerance = <n>} the relative numerical ' // &
          'tolerance $10^{-n}$ for the momentum conservation of the ' // &
          'external particles within \openloops. (cf. also ' // &
          '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
          '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // &
          '\newline\ttt{openloops\_stability\_log}, ' // &
          '\ttt{\$openloops\_extra\_cmd})'))
     call var_list%append_int (var_str ("openloops_stability_log"), 0, &
          intrinsic = .true., &
          description=var_str ('Creates the directory \ttt{stability\_log} ' // &
          'containing information about the performance of the \openloops ' // &
          'matrix elements. Possible values are 0 (No output), 1 (On ' // &
          '\ttt{finish()}-call), 2 (Adaptive) and 3 (Always).'))
     call var_list%append_log (var_str ("?openloops_switch_off_muon_yukawa"), &
          .false., intrinsic = .true., &
          description=var_str ('Sets the Yukawa coupling of muons for ' // &
          '\openloops\ to zero. (cf. also ' // &
          '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
          '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // &
          '\ttt{\$openloops\_extra\_cmd})'))
     call var_list%append_string (var_str ("$openloops_extra_cmd"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('String variable to transfer customized ' // &
          'special commands to \openloops. The three supported examples ' // &
          '\ttt{\$openloops\_extra\_command = "extra approx top/stop/not"} ' // &
          'are for selection of subdiagrams in top production. (cf. also ' // &
          '\ttt{\$method}, \ttt{openloos\_verbosity}, ' // &
          '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // &
          '\ttt{?openloops\_switch\_off\_muon\_yukawa})'))
     call var_list%append_real (var_str ("ellis_sexton_scale"), &
          -1._default, intrinsic = .true., &
          description = var_str ('Real positive paramter for the Ellis-Sexton scale' // &
          '$\mathcal{Q}$ used both in the finite one-loop contribution provided by' // &
          'the OLP and in the virtual counter terms. The NLO cross section is' // &
          'independend of $\mathcal{Q}$. Therefore, this allows for debugging of' // &
          'the implemention of the virtual counter terms. As the default' // &
          '$\mathcal{Q} = \mu_{\rm{R}}$ is chosen. So far, setting this parameter' // &
          'only works for OpenLoops2, otherwise the default behaviour is invoked.'))
     call var_list%append_log (var_str ("?disable_subtraction"), &
          .false., intrinsic = .true., &
          description=var_str ('Disables the subtraction of soft and collinear ' // &
          'divergences from the real matrix element.'))
     call var_list%append_real (var_str ("fks_dij_exp1"), &
          1._default, intrinsic = .true., &
          description=var_str ('Fine-tuning parameters of the FKS ' // &
          'final state partition functions. The exact meaning depends ' // &
          'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp2}, ' // &
          '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})'))
     call var_list%append_real (var_str ("fks_dij_exp2"), &
          1._default, intrinsic = .true., &
          description=var_str ('Fine-tuning parameters of the FKS ' // &
          'initial state partition functions. The exact meaning depends ' // &
          'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp1}, ' // &
          '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})'))
     call var_list%append_real (var_str ("fks_xi_min"), &
          0._default, intrinsic = .true., &
          description=var_str ('Real parameter for the FKS ' // &
          'phase space that sets the numerical lower value of the $\xi$ ' // &
          'variable. Valid for the value range $[\texttt{tiny\_07},1]$, where ' // &
          'value inputs out of bounds will take the value of the closest bound. ' // &
          'Here, $\texttt{tiny\_07} = \texttt{1E0\_default * epsilon (0.\_default)}$, where ' // &
          '\ttt{epsilon} is an intrinsic Fortran function. (cf. also \ttt{fks\_dij\_exp1}, ' // &
          '\ttt{fks\_dij\_exp2}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_y\_max})'))
     call var_list%append_real (var_str ("fks_y_max"), &
          1._default, intrinsic = .true., &
          description=var_str ('Real parameter for the FKS ' // &
          'phase space that sets the numerical upper value of the $\left|y\right|$ ' // &
          'variable. Valid for ranges $[0,1]$, where value inputs out of bounds will take ' // &
          'the value of the closest bound.(cf. also \ttt{fks\_dij\_exp1}, ' // &
          '\ttt{\$fks\_mapping\_type}, \ttt{fks\_dij\_exp2}, \ttt{fks\_y\_max})'))
     call var_list%append_log (var_str ("?vis_fks_regions"), &
          .false., intrinsic = .true., &
          description=var_str ('Logical variable that, if set to ' // &
          '\ttt{true}, generates \LaTeX\ code and executes it into a PDF ' // &
          ' to produce a table of all singular FKS regions and their ' // &
          ' flavor structures. The default is \ttt{false}.'))
     call var_list%append_real (var_str ("fks_xi_cut"), &
          1.0_default, intrinsic = .true., &
          description = var_str ('Real paramter for the FKS ' // &
          'phase space that applies a cut to $\xi$ variable with $0 < \xi_{\text{cut}}' // &
          '\leq \xi_{\text{max}}$. The dependence on the parameter vanishes between ' // &
          'real subtraction and integrated subtraction term.'))
     call var_list%append_real (var_str ("fks_delta_o"), &
          2._default, intrinsic = .true., &
          description = var_str ('Real paramter for the FKS ' // &
          'phase space that applies a cut to the $y$ variable with $0 < \delta_o \leq 2$. ' // &
          'The dependence on the parameter vanishes between real subtraction and integrated ' // &
          'subtraction term.'))
     call var_list%append_real (var_str ("fks_delta_i"), &
          2._default, intrinsic = .true., &
          description = var_str ('Real paramter for the FKS ' // &
          'phase space that applies a cut to the $y$ variable with ' // &
          '$0 < \delta_{\mathrm{I}} \leq 2$ '// &
          'for initial state singularities only. ' // &
          'The dependence on the parameter vanishes between real subtraction and integrated ' // &
          'subtraction term.'))
     call var_list%append_string (var_str ("$fks_mapping_type"), &
          var_str ("default"), intrinsic = .true., &
          description=var_str ('Sets the FKS mapping type. Possible values ' // &
          'are \ttt{"default"} and \ttt{"resonances"}. The latter option ' // &
          'activates the resonance-aware subtraction mode and induces the ' // &
          'generation of a soft mismatch component. (cf. also ' // &
          '\ttt{fks\_dij\_exp1}, \ttt{fks\_dij\_exp2}, \ttt{fks\_xi\_min}, ' // &
          '\ttt{fks\_y\_max})'))
     call var_list%append_string (var_str ("$resonances_exclude_particles"), &
          var_str ("default"), intrinsic = .true., &
          description=var_str ('Accepts a string of particle names. These ' // &
          'particles will be ignored when the resonance histories are generated. ' // &
          'If \ttt{\$fks\_mapping\_type} is not \ttt{"resonances"}, this ' // &
          'option does nothing.'))
     call var_list%append_int (var_str ("alpha_power"), &
          2, intrinsic = .true., &
          description=var_str ('Fixes the electroweak coupling ' // &
          'powers used by BLHA matrix element generators. Setting these ' // &
          'values is necessary for the correct generation of OLP-files. ' // &
          'Having inconsistent values yields to error messages by the corresponding ' // &
          'OLP-providers.'))
     call var_list%append_int (var_str ("alphas_power"), &
          0, intrinsic = .true., &
          description=var_str ('Fixes the strong coupling ' // &
          'powers used by BLHA matrix element generators. Setting these ' // &
          'values is necessary for the correct generation of OLP-files. ' // &
          'Having inconsistent values yields to error messages by the corresponding ' // &
          'OLP-providers.'))
     call var_list%append_log (var_str ("?combined_nlo_integration"), &
          .false., intrinsic = .true., &
          description=var_str ('When this option is set to \ttt{true}, ' // &
          'the NLO integration will not be performed in the separate components, ' // &
          'but instead the sum of all components will be integrated directly. ' // &
          'When fixed-order NLO events are requested, this integration ' // &
          'mode is possible, but not necessary.  However, it is necessary ' // &
          'for POWHEG events.'))
     call var_list%append_log (var_str ("?fixed_order_nlo_events"), &
          .false., intrinsic = .true., &
          description=var_str ('Induces the generation of fixed-order ' // &
          'NLO events.'))
     call var_list%append_log (var_str ("?check_event_weights_against_xsection"), &
          .false., intrinsic = .true., &
          description=var_str ('Activates an internal recording of event ' // &
          'weights when unweighted events are generated.  At the end of ' // &
          'the simulation, the mean value of the weights and its standard ' // &
          'deviation are displayed. This allows to cross-check event generation ' // &
          'and integration, because the value displayed must be equal to ' // &
          'the integration result.'))
     call var_list%append_log (var_str ("?keep_failed_events"), &
          .false., intrinsic = .true., &
          description=var_str ('In the context of weighted event generation, ' // &
          'if set to \ttt{true}, events with failed kinematics will be ' // &
          'written to the event output with an associated weight of zero. ' // &
          'This way, the total cross section can be reconstructed from the event output.'))
     call var_list%append_int (var_str ("gks_multiplicity"), &
          0, intrinsic = .true., &
          description=var_str ('Jet multiplicity for the GKS merging scheme.'))
     call var_list%append_string (var_str ("$gosam_filter_lo"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('The filter string given to \gosam\ in order to ' // &
          'filter out tree-level diagrams. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // &
          '\ttt{\$gosam\_symmetries})'))
     call var_list%append_string (var_str ("$gosam_filter_nlo"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('The same as \ttt{\$gosam\_filter\_lo}, but for ' // &
          'loop matrix elements. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // &
          '\ttt{\$gosam\_symmetries})'))
     call var_list%append_string (var_str ("$gosam_symmetries"), &
          var_str ("family,generation"), intrinsic = .true., &
          description=var_str ('String variable that is transferred to \gosam\ ' // &
          'configuration file to determine whether certain helicity configurations ' // &
          'are considered to be equal. Possible values are \ttt{flavour}, ' // &
          '\ttt{family} etc. For more info see the \gosam\ manual.'))
     call var_list%append_int (var_str ("form_threads"), &
          2, intrinsic = .true., &
          description=var_str ('The number of threads used by \gosam\ when ' // &
          'matrix elements are evaluated using \ttt{FORM}'))
     call var_list%append_int (var_str ("form_workspace"), &
          1000, intrinsic = .true., &
          description=var_str ('The size of the workspace \gosam\ requires ' // &
          'from \ttt{FORM}. Inside \ttt{FORM}, it corresponds to the heap ' // &
          'size used by the algebra processor.'))
     call var_list%append_string (var_str ("$gosam_fc"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('The Fortran compiler used by \gosam.'))
     call var_list%append_real (&
          var_str ("mult_call_real"), 1._default, &
          intrinsic = .true., &
          description=var_str ('(Real-valued) multiplier for the number ' // &
          'of calls used in the integration of the real subtraction ' // &
          'NLO component. This way, a higher accuracy can be achieved for ' // &
          'the real component, while simultaneously avoiding redundant ' // &
          'integration calls for the other components. (cf. also ' // &
          '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_virt})'))
     call var_list%append_real (&
          var_str ("mult_call_virt"), 1._default, &
          intrinsic = .true., &
          description=var_str ('(Real-valued) multiplier for the number ' // &
          'of calls used in the integration of the virtual NLO ' // &
          'component. This way, a higher accuracy can be achieved for ' // &
          'this component, while simultaneously avoiding redundant ' // &
          'integration calls for the other components. (cf. also ' // &
          '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_real})'))
     call var_list%append_real (&
          var_str ("mult_call_dglap"), 1._default, &
          intrinsic = .true., &
          description=var_str ('(Real-valued) multiplier for the number ' // &
          'of calls used in the integration of the DGLAP remnant NLO ' // &
          'component. This way, a higher accuracy can be achieved for ' // &
          'this component, while simultaneously avoiding redundant ' // &
          'integration calls for the other components. (cf. also ' // &
          '\ttt{mult\_call\_real}, \ttt{mult\_call\_virt})'))
     call var_list%append_string (var_str ("$dalitz_plot"), &
          var_str (''), intrinsic = .true., &
          description=var_str ('This string variable has two purposes: ' // &
          'when different from the empty string, it switches on generation ' // &
          'of the Dalitz plot file (ASCII tables) for the real emitters. ' // &
          'The string variable itself provides the file name.'))
     call var_list%append_string (var_str ("$nlo_correction_type"), &
          var_str ("QCD"), intrinsic = .true., &
          description=var_str ('String variable which sets the NLO correction ' // &
          'type via \ttt{nlo\_correction\_type = "{\em <type>}"} to either ' // &
          '\ttt{"QCD"}, \ttt{"EW"}, or to all with \ttt{\em{<type>}} ' // &
          'set to \ttt{"Full"}. Must be set before the \texttt{process} statement.'))
     call var_list%append_string (var_str ("$exclude_gauge_splittings"), &
          var_str ("c:b:t:e2:e3"), intrinsic = .true., &
          description=var_str ('String variable that allows via ' // &
          '\ttt{\$exclude\_gauge\_splittings = "{\em <prt1>:<prt2>:\dots}"} ' // &
          'to exclude fermion flavors from gluon/photon splitting into ' // &
          'fermion pairs beyond LO. For example \ttt{\$exclude\_gauge\_splittings ' // &
          '= "c:s:b:t"} would lead to \ttt{gl => u U} and \ttt{gl => d ' // &
          'D} as possible splittings in QCD. It is important to keep in ' // &
          'mind that only the particles listed in the string are excluded! ' // &
          'In QED this string would additionally allow for all splittings into ' // &
          'lepton pairs \ttt{A => l L}. Therefore, once set the variable ' // &
          'acts as a replacement of the default value, not as an addition!  ' // &
          'Note: \ttt{"\em <prt>"} can be both particle or antiparticle. It ' // &
          'will always exclude the corresponding fermion pair. An empty ' // &
          'string allows for all fermion flavors to take part in the splitting! ' // &
          'Also, particles included in an \ttt{alias} are not excluded by ' // &
          '\ttt{\$exclude\_gauge\_splittings}!'))
     call var_list%append_log (var_str ("?nlo_use_born_scale"), &
          .false., intrinsic = .true., &
          description=var_str ('Flag that decides whether a scale expression ' // &
          'defined for the Born component of an NLO process shall be applied ' // &
          'to all other components as well or not. ' // &
          '(cf. also \ttt{?nlo\_cut\_all\_real\_sqmes})'))
     call var_list%append_log (var_str ("?nlo_cut_all_real_sqmes"), &
          .false., intrinsic = .true., &
          description=var_str ('Flag that decides whether in the case that ' // &
          'the real component does not pass a cut, its subtraction term ' // &
          'shall be discarded for that phase space point as well or not. ' // &
          '(cf. also \ttt{?nlo\_use\_born\_scale})'))
     call var_list%append_log (var_str ("?nlo_use_real_partition"), &
          .false., intrinsic = .true., &
          description=var_str (' If set to \ttt{true}, the real matrix ' // &
          'element is split into a finite and a singular part using a ' // &
          'partition function $f$, such that $\mathcal{R} ' // &
          '= [1-f(p_T^2)]\mathcal{R} + f(p_T^2)\mathcal{R} = ' // &
          '\mathcal{R}_{\text{fin}} ' // &
          '+ \mathcal{R}_{\text{sing}}$. The emission ' // &
          'generation is then performed using $\mathcal{R}_{\text{sing}}$, ' // &
          'whereas $\mathcal{R}_{\text{fin}}$ is treated separately. ' // &
          '(cf. also \ttt{real\_partition\_scale})'))
     call var_list%append_real (var_str ("real_partition_scale"), &
          10._default, intrinsic = .true., &
          description=var_str ('This real variable sets the invariant mass ' // &
          'of the FKS pair used as a separator between the singular and the ' // &
          'finite part of the real subtraction terms in an NLO calculation, ' // &
          'e.g. in $e^+e^- \to ' // &
          't\bar tj$. (cf. also \ttt{?nlo\_use\_real\_partition})'))
+    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
 <<Observables: procedures>>=
   subroutine var_list_set_observables_unary (var_list, prt1)
     type(var_list_t), intent(inout) :: var_list
     type(prt_t), intent(in), target :: prt1
     call var_list_append_obs1_iptr &
          (var_list, var_str ("PDG"), obs_pdg1, prt1)
     call var_list_append_obs1_iptr &
          (var_list, var_str ("Hel"), obs_helicity1, prt1)
     call var_list_append_obs1_iptr &
          (var_list, var_str ("Ncol"), obs_n_col1, prt1)
     call var_list_append_obs1_iptr &
          (var_list, var_str ("Nacl"), obs_n_acl1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("M"), obs_signed_mass1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("M2"), obs_mass_squared1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("E"), obs_energy1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Px"), obs_px1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Py"), obs_py1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Pz"), obs_pz1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("P"), obs_p1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Pl"), obs_pl1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Pt"), obs_pt1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Theta"), obs_theta1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Phi"), obs_phi1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Rap"), obs_rap1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Eta"), obs_eta1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Theta_star"), obs_theta_star1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Dist"), obs_dist1, prt1)
     call var_list_append_uobs_real &
          (var_list, var_str ("_User_obs_real"), prt1)
     call var_list_append_uobs_int &
          (var_list, var_str ("_User_obs_int"), prt1)
   end subroutine var_list_set_observables_unary
 
   subroutine var_list_set_observables_binary (var_list, prt1, prt2)
     type(var_list_t), intent(inout) :: var_list
     type(prt_t), intent(in), target :: prt1
     type(prt_t), intent(in), optional, target :: prt2
     call var_list_append_obs2_iptr &
          (var_list, var_str ("PDG"), obs_pdg2, prt1, prt2)
     call var_list_append_obs2_iptr &
          (var_list, var_str ("Hel"), obs_helicity2, prt1, prt2)
     call var_list_append_obs2_iptr &
          (var_list, var_str ("Ncol"), obs_n_col2, prt1, prt2)
     call var_list_append_obs2_iptr &
          (var_list, var_str ("Nacl"), obs_n_acl2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("M"), obs_signed_mass2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("M2"), obs_mass_squared2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("E"), obs_energy2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Px"), obs_px2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Py"), obs_py2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Pz"), obs_pz2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("P"), obs_p2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Pl"), obs_pl2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Pt"), obs_pt2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Theta"), obs_theta2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Phi"), obs_phi2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Rap"), obs_rap2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Eta"), obs_eta2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Theta_star"), obs_theta_star2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Dist"), obs_dist2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("kT"), obs_ktmeasure, prt1, prt2)
     call var_list_append_uobs_real &
          (var_list, var_str ("_User_obs_real"), prt1, prt2)
     call var_list_append_uobs_int &
          (var_list, var_str ("_User_obs_int"), prt1, prt2)
   end subroutine var_list_set_observables_binary
 
 @ %def var_list_set_observables_unary var_list_set_observables_binary
 @
 \subsection{Checks}
 <<Observables: public>>=
   public :: var_list_check_observable
 <<Observables: procedures>>=
   subroutine var_list_check_observable (var_list, name, type)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(inout) :: type
     if (string_is_observable_id (name)) then
        call msg_fatal ("Variable name '" // char (name) &
             // "' is reserved for an observable")
        type = V_NONE
        return
     end if
   end subroutine var_list_check_observable
 
 @ %def var_list_check_observable
 @
 Check if a variable name is defined as an observable:
 <<Observables: procedures>>=
   function string_is_observable_id (string) result (flag)
     logical :: flag
     type(string_t), intent(in) :: string
     select case (char (string))
     case ("PDG", "Hel", "Ncol", &
          "M", "M2", "E", "Px", "Py", "Pz", "P", "Pl", "Pt", &
          "Theta", "Phi", "Rap", "Eta", "Theta_star", "Dist", "kT")
        flag = .true.
     case default
        flag = .false.
     end select
   end function string_is_observable_id
 
 @ %def string_is_observable_id
 @ Check for result and process variables.
 <<Observables: public>>=
   public :: var_list_check_result_var
 <<Observables: procedures>>=
   subroutine var_list_check_result_var (var_list, name, type)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(inout) :: type
     if (string_is_integer_result_var (name))  type = V_INT
     if (.not. var_list%contains (name)) then
        if (string_is_result_var (name)) then
           call msg_fatal ("Result variable '" // char (name) // "' " &
                // "set without prior integration")
           type = V_NONE
           return
        else if (string_is_num_id (name)) then
           call msg_fatal ("Numeric process ID '" // char (name) // "' " &
                // "set without process declaration")
           type = V_NONE
           return
        end if
     end if
   end subroutine var_list_check_result_var
 
 @ %def var_list_check_result_var
 @
 Check if a variable name is a result variable of integer type:
 <<Observables: procedures>>=
   function string_is_integer_result_var (string) result (flag)
     logical :: flag
     type(string_t), intent(in) :: string
     type(string_t) :: buffer, name, separator
     buffer = string
     call split (buffer, name, "(", separator=separator)  ! ")"
     if (separator == "(") then
        select case (char (name))
        case ("num_id", "n_calls")
           flag = .true.
        case default
           flag = .false.
        end select
     else
        flag = .false.
     end if
   end function string_is_integer_result_var
 
 @ %def string_is_integer_result_var
 @
 Check if a variable name is an integration-result variable:
 <<Observables: procedures>>=
   function string_is_result_var (string) result (flag)
     logical :: flag
     type(string_t), intent(in) :: string
     type(string_t) :: buffer, name, separator
     buffer = string
     call split (buffer, name, "(", separator=separator)  ! ")"
     if (separator == "(") then
        select case (char (name))
        case ("integral", "error")
           flag = .true.
        case default
           flag = .false.
        end select
     else
        flag = .false.
     end if
   end function string_is_result_var
 
 @ %def string_is_result_var
 @
 Check if a variable name is a numeric process ID:
 <<Observables: procedures>>=
   function string_is_num_id (string) result (flag)
     logical :: flag
     type(string_t), intent(in) :: string
     type(string_t) :: buffer, name, separator
     buffer = string
     call split (buffer, name, "(", separator=separator)  ! ")"
     if (separator == "(") then
        select case (char (name))
        case ("num_id")
           flag = .true.
        case default
           flag = .false.
        end select
     else
        flag = .false.
     end if
   end function string_is_num_id
 
 @ %def string_is_num_id
 @
 \subsection{Observables}
 These are analogous to the unary and binary numeric functions listed
 above.  An observable takes the [[pval]] component(s) of its one or
 two argument nodes and produces an integer or real value.
 
 \subsubsection{Integer-valued unary observables}
 The PDG code
 <<Observables: procedures>>=
   integer function obs_pdg1 (prt1) result (pdg)
     type(prt_t), intent(in) :: prt1
     pdg = prt_get_pdg (prt1)
   end function obs_pdg1
 
 @ %def obs_pdg
 @ The helicity.  The return value is meaningful only if the particle
 is polarized, otherwise an invalid value is returned (-9).
 <<Observables: procedures>>=
   integer function obs_helicity1 (prt1) result (h)
     type(prt_t), intent(in) :: prt1
     if (prt_is_polarized (prt1)) then
        h = prt_get_helicity (prt1)
     else
        h = -9
     end if
   end function obs_helicity1
 
 @ %def obs_helicity1
 @ The number of open color (anticolor) lines.  The return value is meaningful
 only if the particle is colorized (i.e., the subevent has been given color
 information), otherwise the function returns zero.
 <<Observables: procedures>>=
   integer function obs_n_col1 (prt1) result (n)
     type(prt_t), intent(in) :: prt1
     if (prt_is_colorized (prt1)) then
        n = prt_get_n_col (prt1)
     else
        n = 0
     end if
   end function obs_n_col1
 
   integer function obs_n_acl1 (prt1) result (n)
     type(prt_t), intent(in) :: prt1
     if (prt_is_colorized (prt1)) then
        n = prt_get_n_acl (prt1)
     else
        n = 0
     end if
   end function obs_n_acl1
 
 @ %def obs_n_col1
 @ %def obs_n_acl1
 @
 \subsubsection{Real-valued unary observables}
 The invariant mass squared, obtained from the separately stored value.
 <<Observables: procedures>>=
   real(default) function obs_mass_squared1 (prt1) result (p2)
     type(prt_t), intent(in) :: prt1
     p2 = prt_get_msq (prt1)
   end function obs_mass_squared1
 
 @ %def obs_mass_squared1
 @ The signed invariant mass, which is the signed square root of the
 previous observable.
 <<Observables: procedures>>=
   real(default) function obs_signed_mass1 (prt1) result (m)
     type(prt_t), intent(in) :: prt1
     real(default) :: msq
     msq = prt_get_msq (prt1)
     m = sign (sqrt (abs (msq)), msq)
   end function obs_signed_mass1
 
 @ %def obs_signed_mass1
 @ The particle energy
 <<Observables: procedures>>=
   real(default) function obs_energy1 (prt1) result (e)
     type(prt_t), intent(in) :: prt1
     e = energy (prt_get_momentum (prt1))
   end function obs_energy1
 
 @ %def obs_energy1
 @ Particle momentum (components)
 <<Observables: procedures>>=
   real(default) function obs_px1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = vector4_get_component (prt_get_momentum (prt1), 1)
   end function obs_px1
 
   real(default) function obs_py1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = vector4_get_component (prt_get_momentum (prt1), 2)
   end function obs_py1
 
   real(default) function obs_pz1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = vector4_get_component (prt_get_momentum (prt1), 3)
   end function obs_pz1
 
   real(default) function obs_p1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = space_part_norm (prt_get_momentum (prt1))
   end function obs_p1
 
   real(default) function obs_pl1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = longitudinal_part (prt_get_momentum (prt1))
   end function obs_pl1
 
   real(default) function obs_pt1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = transverse_part (prt_get_momentum (prt1))
   end function obs_pt1
 
 @ %def obs_px1 obs_py1 obs_pz1
 @ %def obs_p1 obs_pl1 obs_pt1
 @ Polar and azimuthal angle (lab frame).
 <<Observables: procedures>>=
   real(default) function obs_theta1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = polar_angle (prt_get_momentum (prt1))
   end function obs_theta1
 
   real(default) function obs_phi1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = azimuthal_angle (prt_get_momentum (prt1))
   end function obs_phi1
 
 @ %def obs_theta1 obs_phi1
 @ Rapidity and pseudorapidity
 <<Observables: procedures>>=
   real(default) function obs_rap1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = rapidity (prt_get_momentum (prt1))
   end function obs_rap1
 
   real(default) function obs_eta1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = pseudorapidity (prt_get_momentum (prt1))
   end function obs_eta1
 
 @ %def obs_rap1 obs_eta1
 @ Meaningless: Polar angle in the rest frame of the two arguments
 combined.
 <<Observables: procedures>>=
   real(default) function obs_theta_star1 (prt1) result (dist)
     type(prt_t), intent(in) :: prt1
     call msg_fatal (" 'Theta_star' is undefined as unary observable")
     dist = 0
   end function obs_theta_star1
 
 @ %def obs_theta_star1
 @ [Obsolete] Meaningless: Polar angle in the rest frame of the 2nd argument.
 <<XXX Observables: procedures>>=
   real(default) function obs_theta_rf1 (prt1) result (dist)
     type(prt_t), intent(in) :: prt1
     call msg_fatal (" 'Theta_RF' is undefined as unary observable")
     dist = 0
   end function obs_theta_rf1
 
 @ %def obs_theta_rf1
 @ Meaningless: Distance on the $\eta$-$\phi$ cylinder.
 <<Observables: procedures>>=
   real(default) function obs_dist1 (prt1) result (dist)
     type(prt_t), intent(in) :: prt1
     call msg_fatal (" 'Dist' is undefined as unary observable")
     dist = 0
   end function obs_dist1
 
 @ %def obs_dist1
 @
 \subsubsection{Integer-valued binary observables}
 These observables are meaningless as binary functions.
 <<Observables: procedures>>=
   integer function obs_pdg2 (prt1, prt2) result (pdg)
     type(prt_t), intent(in) :: prt1, prt2
     call msg_fatal (" PDG_Code is undefined as binary observable")
     pdg = 0
   end function obs_pdg2
 
   integer function obs_helicity2 (prt1, prt2) result (h)
     type(prt_t), intent(in) :: prt1, prt2
     call msg_fatal (" Helicity is undefined as binary observable")
     h = 0
   end function obs_helicity2
 
   integer function obs_n_col2 (prt1, prt2) result (n)
     type(prt_t), intent(in) :: prt1, prt2
     call msg_fatal (" Ncol is undefined as binary observable")
     n = 0
   end function obs_n_col2
 
   integer function obs_n_acl2 (prt1, prt2) result (n)
     type(prt_t), intent(in) :: prt1, prt2
     call msg_fatal (" Nacl is undefined as binary observable")
     n = 0
   end function obs_n_acl2
 
 @ %def obs_pdg2
 @ %def obs_helicity2
 @ %def obs_n_col2
 @ %def obs_n_acl2
 @
 \subsubsection{Real-valued binary observables}
 The invariant mass squared, obtained from the separately stored value.
 <<Observables: procedures>>=
   real(default) function obs_mass_squared2 (prt1, prt2) result (p2)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p2 = prt_get_msq (prt)
   end function obs_mass_squared2
 
 @ %def obs_mass_squared2
 @ The signed invariant mass, which is the signed square root of the
 previous observable.
 <<Observables: procedures>>=
   real(default) function obs_signed_mass2 (prt1, prt2) result (m)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     real(default) :: msq
     call prt_init_combine (prt, prt1, prt2)
     msq = prt_get_msq (prt)
     m = sign (sqrt (abs (msq)), msq)
   end function obs_signed_mass2
 
 @ %def obs_signed_mass2
 @ The particle energy
 <<Observables: procedures>>=
   real(default) function obs_energy2 (prt1, prt2) result (e)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     e = energy (prt_get_momentum (prt))
   end function obs_energy2
 
 @ %def obs_energy2
 @ Particle momentum (components)
 <<Observables: procedures>>=
   real(default) function obs_px2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = vector4_get_component (prt_get_momentum (prt), 1)
   end function obs_px2
 
   real(default) function obs_py2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = vector4_get_component (prt_get_momentum (prt), 2)
   end function obs_py2
 
   real(default) function obs_pz2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = vector4_get_component (prt_get_momentum (prt), 3)
   end function obs_pz2
 
   real(default) function obs_p2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = space_part_norm (prt_get_momentum (prt))
   end function obs_p2
 
   real(default) function obs_pl2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = longitudinal_part (prt_get_momentum (prt))
   end function obs_pl2
 
   real(default) function obs_pt2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = transverse_part (prt_get_momentum (prt))
   end function obs_pt2
 
 @ %def obs_px2 obs_py2 obs_pz2
 @ %def obs_p2 obs_pl2 obs_pt2
 @ Enclosed angle and azimuthal distance (lab frame).
 <<Observables: procedures>>=
   real(default) function obs_theta2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     p = enclosed_angle (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_theta2
 
   real(default) function obs_phi2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = azimuthal_distance (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_phi2
 
 @ %def obs_theta2 obs_phi2
 @ Rapidity and pseudorapidity distance
 <<Observables: procedures>>=
   real(default) function obs_rap2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     p = rapidity_distance &
          (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_rap2
 
   real(default) function obs_eta2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = pseudorapidity_distance &
          (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_eta2
 
 @ %def obs_rap2 obs_eta2
 @ [This doesn't work!  The principle of no common particle for momentum
   combination prohibits us from combining a decay particle with the momentum
   of its parent.] Polar angle in the rest frame of the 2nd argument.
 <<XXX Observables: procedures>>=
   real(default) function obs_theta_rf2 (prt1, prt2) result (theta)
     type(prt_t), intent(in) :: prt1, prt2
     theta = enclosed_angle_rest_frame &
          (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_theta_rf2
 
 @ %def obs_theta_rf2
 @ Polar angle of the first particle in the rest frame of the two particles
 combined.
 <<Observables: procedures>>=
   real(default) function obs_theta_star2 (prt1, prt2) result (theta)
     type(prt_t), intent(in) :: prt1, prt2
     theta = enclosed_angle_rest_frame &
          (prt_get_momentum (prt1), &
          prt_get_momentum (prt1) + prt_get_momentum (prt2))
   end function obs_theta_star2
 
 @ %def obs_theta_star2
 @ Distance on the $\eta$-$\phi$ cylinder.
 <<Observables: procedures>>=
   real(default) function obs_dist2 (prt1, prt2) result (dist)
     type(prt_t), intent(in) :: prt1, prt2
     dist = eta_phi_distance &
          (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_dist2
 
 @ %def obs_dist2
 @ Durham kT measure.
 <<Observables: procedures>>=
   real(default) function obs_ktmeasure (prt1, prt2) result (kt)
     type(prt_t), intent(in) :: prt1, prt2
     real (default) :: q2, e1, e2
     ! Normalized scale to one for now! (#67)
     q2 = 1
     e1 = energy (prt_get_momentum (prt1))
     e2 = energy (prt_get_momentum (prt2))
     kt = (2/q2) * min(e1**2,e2**2) *  &
          (1 - enclosed_angle_ct(prt_get_momentum (prt1), &
          prt_get_momentum (prt2)))
   end function obs_ktmeasure
 
 @ %def obs_ktmeasure
Index: trunk/src/process_integration/process_integration.nw
===================================================================
--- trunk/src/process_integration/process_integration.nw	(revision 8444)
+++ trunk/src/process_integration/process_integration.nw	(revision 8445)
@@ -1,19265 +1,19438 @@
 % -*- 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 won't 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), intent(out) :: fac_scale
     real(default), 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 (force_scale) then
           fac_scale = scale_forced
        else if (expr%has_fac_scale) then
           call expr%fac_scale%evaluate ()
           if (expr%fac_scale%is_known ()) then
              fac_scale = expr%fac_scale%get_real ()
           else
              call msg_error ("Evaluate factorization scale expression: &
                   &result undefined")
              fac_scale = zero
           end if
        else
           fac_scale = scale
        end if
        if (force_scale) then
           ren_scale = scale_forced
        else if (expr%has_ren_scale) then
           call expr%ren_scale%evaluate ()
           if (expr%ren_scale%is_known ()) then
              ren_scale = expr%ren_scale%get_real ()
           else
              call msg_error ("Evaluate renormalization scale expression: &
                   &result undefined")
              ren_scale = zero
           end if
        else
           ren_scale = scale
        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 fore 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
-@ Setup an identity-evaluator for the trace. This implies that [[me]]
+@ 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
-@ Setup the evaluator for the transition matrix, exclusive in
+@ 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}
-Setup a trace evaluator as a product of two evaluators (incoming 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
-@ Setup a matrix evaluator as a product of two evaluators (incoming
+@ 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
-@ Setup a matrix evaluator as a product of two evaluators (incoming
+@ 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.
 <<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)
     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., .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
     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, fac_scale, ren_scale, weight
     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
 
     !!! Don't 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}
 This object may hold process and method-specific data, and it should
 allocate the corresponding manager instance.
 
 The number of components determines the [[component_selected]] array.
 
 [[i_phs_config]] is a lookup table that returns the PHS configuration index
 for a given component index.
 
 [[i_core]] is a lookup table that returns the core-entry 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_instance), deferred :: allocate_instance
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_allocate_instance (pcm, instance)
        import
        class(pcm_t), intent(in) :: pcm
        class(pcm_instance_t), intent(inout), allocatable :: instance
      end subroutine pcm_allocate_instance
   end interface
 
 @ %def pcm_allocate_instance
 @
 <<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 instance}
 This object deals with the actual (squared) matrix element values.
 <<PCM base: public>>=
   public :: pcm_instance_t
 <<PCM base: types>>=
   type, abstract :: pcm_instance_t
     class(pcm_t), pointer :: config => null ()
     logical :: bad_point = .false.
   contains
   <<PCM base: pcm instance: TBP>>
   end type pcm_instance_t
 
 @ %def pcm_instance_t
 @
 <<PCM base: pcm instance: TBP>>=
   procedure(pcm_instance_final), deferred :: final
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_instance_final (pcm_instance)
         import
         class(pcm_instance_t), intent(inout) :: pcm_instance
      end subroutine pcm_instance_final
   end interface
 
 @ %def pcm_instance_final
 @
 <<PCM base: pcm instance: TBP>>=
   procedure :: link_config => pcm_instance_link_config
 <<PCM base: procedures>>=
   subroutine pcm_instance_link_config (pcm_instance, config)
      class(pcm_instance_t), intent(inout) :: pcm_instance
      class(pcm_t), intent(in), target :: config
      pcm_instance%config => config
   end subroutine pcm_instance_link_config
 
 @ %def pcm_instance_link_config
 @
 <<PCM base: pcm instance: TBP>>=
   procedure :: is_valid => pcm_instance_is_valid
 <<PCM base: procedures>>=
   function pcm_instance_is_valid (pcm_instance) result (valid)
     logical :: valid
     class(pcm_instance_t), intent(in) :: pcm_instance
     valid = .not. pcm_instance%bad_point
   end function pcm_instance_is_valid
 
 @ %def pcm_instance_is_valid
 @
 <<PCM base: pcm instance: TBP>>=
   procedure :: set_bad_point => pcm_instance_set_bad_point
 <<PCM base: procedures>>=
   pure subroutine pcm_instance_set_bad_point (pcm_instance, bad_point)
     class(pcm_instance_t), intent(inout) :: pcm_instance
     logical, intent(in) :: bad_point
     pcm_instance%bad_point = pcm_instance%bad_point .or. bad_point
   end subroutine pcm_instance_set_bad_point
 
 @ %def pcm_instance_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}
 A process object is the workspace for the process instance.
 After initialization, its contents are filled by
 integration passes which shape the integration grids and compute cross
 sections.  Processes are set up initially from user-level
 configuration data.  After calculating integrals and thus developing
 integration grid data, the program may use a process
 object or a copy of it for the purpose of generating events.
 
 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 [[type]] determines whether we are considering a decay or a
 scattering process.
 
 The [[meta]] object describes the process and its environment.  All
 contents become fixed when the object is initialized.
 
 The [[config]] object holds physical and technical configuration data
 that have been obtained during process initialization, and which are
 common to all process components.
 
 The individual process components are configured in the [[component]]
 objects.  These objects contain more configuration parameters and
 workspace, as needed for the specific process variant.
 
 The [[term]] objects describe parton configurations which are
 technically used as phase-space points.  Each process component may
 split into several terms with distinct kinematics and particle
 content.  Furthermore, each term may project on a different physical
 state, e.g., by particle recombination.  The [[term]] object provides
 the framework for this projection, for applying cuts, weight, and thus
 completing the process calculation.
 
 The [[beam_config]] object describes the incoming particles, either the
 decay mother or the scattering beams.  It also contains the structure-function
 information.
 
 The [[mci_entry]] objects configure a MC input parameter set and integrator,
 each.  The number of parameters depends on the process component and on the
 beam and structure-function setup.
 
 The [[pcm]] component is the process-component manager.  This
 polymorphic object manages and hides the details of dealing with NLO
 processes where several components have to be combined in a
 non-trivial way.  It also acts as an abstract factory for the
 corresponding object in [[process_instance]], which does the actual
 work for this matter.
 <<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%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
          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
+    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.)
 <<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 (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 LO and the NLO result $\iota = I_{LO} / I_{NLO}$. 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
     real(default) :: int_born, int_nlo
     int_nlo = zero
     int_born = process%mci_entry(1)%get_integral ()
     do i_mci = 2, size (process%mci_entry)
        if (process%component_can_be_integrated (i_mci)) &
           int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral ()
     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
     sum_int_nlo = zero; err2 = zero
     int_born = process%mci_entry(1)%get_integral ()
     err_born = process%mci_entry(1)%get_error ()
     do i_mci = 2, size (process%mci_entry)
        if (process%component_can_be_integrated (i_mci)) then
           sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral ()
           err2 = err2 + process%mci_entry(i_mci)%get_error()**2
        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 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 :: 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 doesn't 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.
 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
       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
      integer :: associated_real_component = 0
    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
        n = get_n_components (mci_entry%real_partition_type)
        allocate (i_list (n))
        if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
             "mci_entry%real_partition_type", mci_entry%real_partition_type)
        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 (damping_type) result (n_components)
       integer :: n_components
       integer, intent(in) :: damping_type
       select case (damping_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
 @
 <<Process mci: process mci entry: TBP>>=
   procedure :: set_associated_real_component &
       => process_mci_entry_set_associated_real_component
 <<Process mci: procedures>>=
   subroutine process_mci_entry_set_associated_real_component (mci_entry, i)
      class(process_mci_entry_t), intent(inout) :: mci_entry
      integer, intent(in) :: i
      mci_entry%associated_real_component = i
   end subroutine process_mci_entry_set_associated_real_component
 
 @ %def process_mci_entry_set_associated_real_component
 @ 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 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_instance => pcm_default_allocate_instance
 <<Pcm: procedures>>=
   subroutine pcm_default_allocate_instance (pcm, instance)
     class(pcm_default_t), intent(in) :: pcm
     class(pcm_instance_t), intent(inout), allocatable :: instance
     allocate (pcm_instance_default_t :: instance)
   end subroutine pcm_default_allocate_instance
 
 @ %def pcm_default_allocate_instance
 @
 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_instance_t) :: pcm_instance_default_t
   contains
   <<Pcm: pcm instance default: TBP>>
   end type pcm_instance_default_t
 
 @ %def pcm_instance_default_t
 @
 <<Pcm: pcm instance default: TBP>>=
   procedure :: final => pcm_instance_default_final
 <<Pcm: procedures>>=
   subroutine pcm_instance_default_final (pcm_instance)
     class(pcm_instance_default_t), intent(inout) :: pcm_instance
   end subroutine pcm_instance_default_final
 
 @ %def pcm_instance_default_final
 @
 \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.
      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'))
     pcm%use_real_partition = &
          var_list%get_lval (var_str ("?nlo_use_real_partition"))
     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 (first_real_component) then
              pcm%i_phs_config(i) = 2
              if (pcm%use_real_partition)  first_real_component = .false.
           else
              pcm%i_phs_config(i) = 1
           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 :: i
     call pcm%handle_threshold_core (core_entry)
     call pcm%setup_region_data &
          (core_entry, component(pcm%i_real)%phs_config, model)
     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)
     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
     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)
     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_instance => pcm_nlo_allocate_instance
 <<Pcm: procedures>>=
   subroutine pcm_nlo_allocate_instance (pcm, instance)
     class(pcm_nlo_t), intent(in) :: pcm
     class(pcm_instance_t), intent(inout), allocatable :: instance
     allocate (pcm_instance_nlo_t :: instance)
   end subroutine pcm_nlo_allocate_instance
 
 @ %def pcm_nlo_allocate_instance
 @
 <<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_instance, generator, &
      sqrts, mode, singular_jacobian)
     class(pcm_nlo_t), intent(in) :: pcm
     type(phs_fks_generator_t), intent(inout) :: generator
     type(pcm_instance_nlo_t), intent(in), target :: pcm_instance
     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_instance%isr_kinematics, &
          pcm_instance%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_instance_nlo_t
 <<Pcm: types>>=
   type, extends (pcm_instance_t) :: pcm_instance_nlo_t
      logical :: use_internal_color_correlation = .true.
      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_instance_nlo_t
 
 @ %def pcm_instance_nlo_t
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_radiation_event => pcm_instance_nlo_set_radiation_event
   procedure :: set_subtraction_event => pcm_instance_nlo_set_subtraction_event
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_radiation_event (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%radiation_event = .true.
     pcm_instance%real_sub%subtraction_event = .false.
   end subroutine pcm_instance_nlo_set_radiation_event
 
   subroutine pcm_instance_nlo_set_subtraction_event (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%radiation_event = .false.
     pcm_instance%real_sub%subtraction_event = .true.
   end subroutine pcm_instance_nlo_set_subtraction_event
 
 @ %def pcm_instance_nlo_set_radiation_event
 @ %def pcm_instance_nlo_set_subtraction_event
 <<Pcm: pcm instance: TBP>>=
   procedure :: disable_subtraction => pcm_instance_nlo_disable_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_disable_subtraction (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%subtraction_deactivated = .true.
   end subroutine pcm_instance_nlo_disable_subtraction
 
 @ %def pcm_instance_nlo_disable_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_config => pcm_instance_nlo_init_config
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_config (pcm_instance, active_components, &
      nlo_types, sqrts, i_real_fin, model)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     logical, intent(in), dimension(:) :: active_components
     integer, intent(in), dimension(:) :: nlo_types
     real(default), intent(in) :: sqrts
     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_instance_nlo_init_config")
     call pcm_instance%init_real_and_isr_kinematics (sqrts)
     select type (pcm => pcm_instance%config)
     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_instance%setup_real_component &
                         (pcm%settings%fks_template%subtraction_disabled)
                 end if
              case (NLO_VIRTUAL)
                 call pcm_instance%init_virtual (model)
              case (NLO_MISMATCH)
                 call pcm_instance%init_soft_mismatch ()
              case (NLO_DGLAP)
                 call pcm_instance%init_dglap_remnant ()
              end select
           end if
        end do
     end select
   end subroutine pcm_instance_nlo_init_config
 
 @ %def pcm_instance_nlo_init_config
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: setup_real_component => pcm_instance_nlo_setup_real_component
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_setup_real_component (pcm_instance, &
      subtraction_disabled)
     class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
     logical, intent(in) :: subtraction_disabled
     call pcm_instance%init_real_subtraction ()
     if (subtraction_disabled)  call pcm_instance%disable_subtraction ()
   end subroutine pcm_instance_nlo_setup_real_component
 
 @ %def pcm_instance_nlo_setup_real_component
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_real_and_isr_kinematics => &
        pcm_instance_nlo_init_real_and_isr_kinematics
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_real_and_isr_kinematics (pcm_instance, sqrts)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default) :: sqrts
     integer :: n_contr
     allocate (pcm_instance%real_kinematics)
     allocate (pcm_instance%isr_kinematics)
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        associate (region_data => config%region_data)
           if (allocated (region_data%alr_contributors)) then
              n_contr = size (region_data%alr_contributors)
           else if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
              n_contr = 2
           else
              n_contr = 1
           end if
           call pcm_instance%real_kinematics%init &
                (region_data%n_legs_real, region_data%n_phs, &
                region_data%n_regions, n_contr)
           if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
              call pcm_instance%real_kinematics%init_onshell &
                   (region_data%n_legs_real, region_data%n_phs)
           pcm_instance%isr_kinematics%n_in = region_data%n_in
        end associate
     end select
     pcm_instance%isr_kinematics%beam_energy = sqrts / two
   end subroutine pcm_instance_nlo_init_real_and_isr_kinematics
 
 @ %def pcm_instance_nlo_init_real_and_isr_kinematics
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_real_and_isr_kinematics => &
       pcm_instance_nlo_set_real_and_isr_kinematics
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_real_and_isr_kinematics (pcm_instance, phs_identifiers, sqrts)
     class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     real(default), intent(in) :: sqrts
     call pcm_instance%real_sub%set_real_kinematics &
          (pcm_instance%real_kinematics)
     call pcm_instance%real_sub%set_isr_kinematics &
          (pcm_instance%isr_kinematics)
   end subroutine pcm_instance_nlo_set_real_and_isr_kinematics
 
 @ %def pcm_instance_nlo_set_real_and_isr_kinematics
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_real_subtraction => pcm_instance_nlo_init_real_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_real_subtraction (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        associate (region_data => config%region_data)
           call pcm_instance%real_sub%init (region_data, config%settings)
           if (allocated (config%settings%selected_alr)) then
               associate (selected_alr => config%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_instance%real_sub%selected_alr (size (selected_alr)))
                    pcm_instance%real_sub%selected_alr = selected_alr
                 end if
              end associate
           end if
        end associate
     end select
   end subroutine pcm_instance_nlo_init_real_subtraction
 
 @ %def pcm_instance_nlo_init_real_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_momenta_and_scales_virtual => &
      pcm_instance_nlo_set_momenta_and_scales_virtual
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_momenta_and_scales_virtual (pcm_instance, p, &
      ren_scale, fac_scale, es_scale)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: ren_scale, fac_scale, es_scale
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        associate (virtual => pcm_instance%virtual)
           call virtual%set_ren_scale (p, ren_scale)
           call virtual%set_fac_scale (p, fac_scale)
           call virtual%set_ellis_sexton_scale (es_scale)
        end associate
     end select
   end subroutine pcm_instance_nlo_set_momenta_and_scales_virtual
 
 @ %def pcm_instance_nlo_set_momenta_and_scales_virtual
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_fac_scale => pcm_instance_nlo_set_fac_scale
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_fac_scale (pcm_instance, fac_scale)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), intent(in) :: fac_scale
     pcm_instance%isr_kinematics%fac_scale = fac_scale
   end subroutine pcm_instance_nlo_set_fac_scale
 
 @ %def pcm_instance_nlo_set_fac_scale
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_momenta => pcm_instance_nlo_set_momenta
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_momenta (pcm_instance, p_born, p_real, i_phs, cms)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     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_instance%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 = p_born
           kinematics%p_real_cms%phs_point(i_phs)%p = 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 = p_born
           kinematics%p_real_lab%phs_point(i_phs)%p = p_real
        end if
     end associate
   end subroutine pcm_instance_nlo_set_momenta
 
 @ %def pcm_instance_nlo_set_momenta
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_momenta => pcm_instance_nlo_get_momenta
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_momenta (pcm_instance, i_phs, born_phsp, cms) result (p)
     type(vector4_t), dimension(:), allocatable :: p
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     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 (config => pcm_instance%config)
     type is (pcm_nlo_t)
        if (born_phsp) then
           if (yorn) then
              allocate (p (1 : config%region_data%n_legs_born), &
                 source = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p)
           else
              allocate (p (1 : config%region_data%n_legs_born), &
                 source = pcm_instance%real_kinematics%p_born_lab%phs_point(1)%p)
           end if
        else
           if (yorn) then
              allocate (p (1 : config%region_data%n_legs_real), &
                 source = pcm_instance%real_kinematics%p_real_cms%phs_point(i_phs)%p)
           else
              allocate (p ( 1 : config%region_data%n_legs_real), &
                   source = pcm_instance%real_kinematics%p_real_lab%phs_point(i_phs)%p)
           end if
        end if
     end select
   end function pcm_instance_nlo_get_momenta
 
 @ %def pcm_instance_nlo_get_momenta
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_xi_max => pcm_instance_nlo_get_xi_max
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_xi_max (pcm_instance, alr) result (xi_max)
     real(default) :: xi_max
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     integer, intent(in) :: alr
     integer :: i_phs
     i_phs = pcm_instance%real_kinematics%alr_to_i_phs (alr)
     xi_max = pcm_instance%real_kinematics%xi_max (i_phs)
   end function pcm_instance_nlo_get_xi_max
 
 @ %def pcm_instance_nlo_get_xi_max
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_n_born => pcm_instance_nlo_get_n_born
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_n_born (pcm_instance) result (n_born)
     integer :: n_born
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        n_born = config%region_data%n_legs_born
     end select
   end function pcm_instance_nlo_get_n_born
 
 @ %def pcm_instance_nlo_get_n_born
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_n_real => pcm_instance_nlo_get_n_real
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_n_real (pcm_instance) result (n_real)
     integer :: n_real
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        n_real = config%region_data%n_legs_real
     end select
   end function pcm_instance_nlo_get_n_real
 
 @ %def pcm_instance_nlo_get_n_real
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_n_regions => pcm_instance_nlo_get_n_regions
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_n_regions (pcm_instance) result (n_regions)
     integer :: n_regions
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        n_regions = config%region_data%n_regions
     end select
   end function pcm_instance_nlo_get_n_regions
 
 @ %def pcm_instance_nlo_get_n_regions
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_x_rad => pcm_instance_nlo_set_x_rad
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_x_rad (pcm_instance, x_tot)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), intent(in), dimension(:) :: x_tot
     integer :: n_par
     n_par = size (x_tot)
     if (n_par < 3) then
        pcm_instance%real_kinematics%x_rad = zero
     else
        pcm_instance%real_kinematics%x_rad = x_tot (n_par - 2 : n_par)
     end if
   end subroutine pcm_instance_nlo_set_x_rad
 
 @ %def pcm_instance_nlo_set_x_rad
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_virtual => pcm_instance_nlo_init_virtual
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_virtual (pcm_instance, model)
     class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
     class(model_data_t), intent(in) :: model
     type(nlo_settings_t), pointer :: settings
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        associate (region_data => config%region_data)
          settings => config%settings
          call pcm_instance%virtual%init (region_data%get_flv_states_born (), &
               region_data%n_in, settings, &
               region_data%regions(1)%nlo_correction_type, model, config%has_pdfs)
        end associate
     end select
   end subroutine pcm_instance_nlo_init_virtual
 
 @ %def pcm_instance_nlo_init_virtual
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: disable_virtual_subtraction => pcm_instance_nlo_disable_virtual_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_disable_virtual_subtraction (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
   end subroutine pcm_instance_nlo_disable_virtual_subtraction
 
 @ %def pcm_instance_nlo_disable_virtual_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_virt => pcm_instance_nlo_compute_sqme_virt
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_compute_sqme_virt (pcm_instance, p, &
          alpha_coupling, separate_uborns, sqme_virt)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), 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_instance%virtual)
        allocate (pp (size (p)))
        if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
           pp = pcm_instance%real_kinematics%p_born_onshell%get_momenta (1)
        else
           pp = p
        end if
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           if (separate_uborns) then
              allocate (sqme_virt (config%get_n_flv_born ()))
           else
              allocate (sqme_virt (1))
           end if
           sqme_virt = zero
           call virtual%evaluate (config%region_data, &
                alpha_coupling, pp, separate_uborns, sqme_virt)
        end select
     end associate
   end subroutine pcm_instance_nlo_compute_sqme_virt
 
 @ %def pcm_instance_nlo_compute_sqme_virt
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_mismatch => pcm_instance_nlo_compute_sqme_mismatch
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_compute_sqme_mismatch (pcm_instance, &
            alpha_s, separate_uborns, sqme_mism)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), intent(in) :: alpha_s
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), allocatable, intent(inout) :: sqme_mism
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        if (separate_uborns) then
           allocate (sqme_mism (config%get_n_flv_born ()))
        else
           allocate (sqme_mism (1))
        end if
        sqme_mism = zero
        sqme_mism = pcm_instance%soft_mismatch%evaluate (alpha_s)
     end select
   end subroutine pcm_instance_nlo_compute_sqme_mismatch
 
 @ %def pcm_instance_nlo_compute_sqme_mismatch
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_dglap_remnant => pcm_instance_nlo_compute_sqme_dglap_remnant
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_compute_sqme_dglap_remnant (pcm_instance, &
             alpha_s, separate_uborns, sqme_dglap)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), intent(in) :: alpha_s
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        if (separate_uborns) then
           allocate (sqme_dglap (config%get_n_flv_born ()))
        else
           allocate (sqme_dglap (1))
        end if
     end select
     sqme_dglap = zero
     call pcm_instance%dglap_remnant%evaluate (alpha_s, separate_uborns, sqme_dglap)
   end subroutine pcm_instance_nlo_compute_sqme_dglap_remnant
 
 @ %def pcm_instance_nlo_compute_sqme_dglap_remnant
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_fixed_order_event_mode => pcm_instance_nlo_set_fixed_order_event_mode
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_fixed_order_event_mode (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%purpose = FIXED_ORDER_EVENTS
   end subroutine pcm_instance_nlo_set_fixed_order_event_mode
 
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_powheg_mode => pcm_instance_nlo_set_powheg_mode
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_powheg_mode (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%purpose = POWHEG
   end subroutine pcm_instance_nlo_set_powheg_mode
 
 @ %def pcm_instance_nlo_set_fixed_order_event_mode
 @ %def pcm_instance_nlo_set_powheg_mode
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_soft_mismatch => pcm_instance_nlo_init_soft_mismatch
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_soft_mismatch (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        call pcm_instance%soft_mismatch%init (config%region_data, &
             pcm_instance%real_kinematics, config%settings%factorization_mode)
     end select
   end subroutine pcm_instance_nlo_init_soft_mismatch
 
 @ %def pcm_instance_nlo_init_soft_mismatch
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_dglap_remnant => pcm_instance_nlo_init_dglap_remnant
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_dglap_remnant (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        call pcm_instance%dglap_remnant%init ( &
             config%settings, &
             config%region_data, &
             pcm_instance%isr_kinematics)
     end select
   end subroutine pcm_instance_nlo_init_dglap_remnant
 
 @ %def pcm_instance_nlo_init_dglap_remnant
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: is_fixed_order_nlo_events &
        => pcm_instance_nlo_is_fixed_order_nlo_events
 <<Pcm: procedures>>=
   function pcm_instance_nlo_is_fixed_order_nlo_events (pcm_instance) result (is_nlo)
     logical :: is_nlo
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     is_nlo = pcm_instance%real_sub%purpose == FIXED_ORDER_EVENTS
   end function pcm_instance_nlo_is_fixed_order_nlo_events
 
 @ %def pcm_instance_nlo_is_fixed_order_nlo_events
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: final => pcm_instance_nlo_final
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_final (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     call pcm_instance%real_sub%final ()
     call pcm_instance%virtual%final ()
     call pcm_instance%soft_mismatch%final ()
     call pcm_instance%dglap_remnant%final ()
     if (associated (pcm_instance%real_kinematics)) then
        call pcm_instance%real_kinematics%final ()
        nullify (pcm_instance%real_kinematics)
     end if
     if (associated (pcm_instance%isr_kinematics)) then
        nullify (pcm_instance%isr_kinematics)
     end if
   end subroutine pcm_instance_nlo_final
 
 @ %def pcm_instance_nlo_final
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \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 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, only: pcm_instance_nlo_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
 @ 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
 @ 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)
        call phs%generate_radiation_variables &
             (r_in(phs%n_r_born + 1 : phs%n_r_born + 3), k%threshold)
        call phs%compute_cms_energy ()
     end select
   end subroutine kinematics_evaluate_radiation_kinematics
 
 @ %def kinematics_evaluate_radiation_kinematics
 @
 <<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
 @ 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
 @ 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, sf_rescale)
     class(kinematics_t), intent(inout) :: k
     real(default), intent(in) :: fac_scale
     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, 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_instance, nlo_type)
     class(kinematics_t), intent(inout) :: k
     type(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     integer, intent(in) :: nlo_type
     real(default) :: sqrts, mtop
     type(lorentz_transformation_t) :: L_to_cms
     type(vector4_t), dimension(:), allocatable :: p_tot
     integer :: n_tot
     n_tot = k%phs%get_n_tot ()
     allocate (p_tot (size (pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p)))
     select type (phs => k%phs)
     type is (phs_fks_t)
        p_tot = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p
     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_instance%real_kinematics%p_born_cms%set_momenta (1, p_tot)
     associate (p_onshell => pcm_instance%real_kinematics%p_born_onshell%phs_point(1)%p)
        call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell)
        if (debug2_active (D_THRESHOLD)) then
           print *, 'On-shell projected Born: '
           call vector4_write_set (p_onshell)
        end if
     end associate
   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 [[k_term]] object is the instance of the kinematics setup
 (structure-function chain, phase space, etc.) that applies
 specifically to this term.  In ordinary cases, it consists of straight
 pointers to the seed kinematics.
 
 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 ()
      logical :: active = .false.
      type(kinematics_t) :: k_term
      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) :: fac_scale = 0
      real(default) :: ren_scale = 0
      real(default) :: es_scale = 0
      real(default), allocatable :: alpha_qcd_forced
      real(default) :: weight = 1
      type(vector4_t), dimension(:), allocatable :: p_seed
      type(vector4_t), dimension(:), allocatable :: p_hard
      class(pcm_instance_t), pointer :: pcm_instance => null ()
      integer :: nlo_type = BORN
      integer, dimension(:), allocatable :: same_kinematics
    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, show_eff_state, testflag)
     class(term_instance_t), intent(in) :: term
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_eff_state
     logical, intent(in), optional :: testflag
     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%fac_scale
        write (u, "(3x,A,ES19.12)")  "renormalization scale = ", term%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
     call term%k_term%write (u)
     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%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%k_term%final ()
     call term%connected%final ()
     call term%isolated%final ()
     call term%int_hard%final ()
     term%pcm_instance => null ()
   end subroutine term_instance_final
 
 @ %def term_instance_final
 @ For initialization, we make use of defined assignment for the
 [[interaction_t]] type.  This creates a deep copy.
 
 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 :: init => term_instance_init
 <<Instances: procedures>>=
   subroutine term_instance_init (term, process, i_term, real_finite)
     class(term_instance_t), intent(inout), target :: term
     type(process_t), intent(in), target:: process
     integer, intent(in) :: i_term
     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)
     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 => term%k_term%sf_chain%get_out_int_ptr ()
     n_in = term%int_hard%get_n_in ()
     do j = 1, n_in
        i = term%k_term%sf_chain%get_out_i (j)
        call term%int_hard%set_source_link (j, sf_chain_int, i)
     end do
     call term%isolated%init (term%k_term%sf_chain, term%int_hard)
     allocate (mask_in (n_in))
     mask_in = term%k_term%sf_chain%get_out_mask ()
     select type (phs => term%k_term%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
     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, &
          is_polarized = .false.)
     call term%init_interaction_qn_index (core, term%int_hard, n_sub)
     if (requires_extended_sf) then
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           n_in = config%region_data%get_n_in ()
           flv_born = config%region_data%get_flv_states_born ()
           flv_real = config%region_data%get_flv_states_real ()
           n_flv_born = config%region_data%get_n_flv_born ()
           n_flv_real = config%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
 
 <<Instances: term instance init: procedures>>
   end subroutine term_instance_init
 
 @ %def term_instance_init
-@ Setup index mapping from state matrix to index pair [[i_flv]], [[i_sub]].
+@ 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
-@ Setup beam polarisation quantum numbers, if beam polarisation is required.
+@ 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, 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
     logical, intent(in), optional :: is_polarized
     logical :: polarized
     type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config
     select type (core)
     class is (prc_external_t)
        select type (pcm_instance => term%pcm_instance)
        type is (pcm_instance_nlo_t)
           associate (is_born => .not. (term%nlo_type == NLO_REAL .and. &
                   .not. term%is_subtraction ()))
              select type (config => pcm_instance%config)
              type is (pcm_nlo_t)
                 qn_config = config%get_qn (is_born)
              end select
              if (present (is_polarized)) then
                 polarized = is_polarized
              else
                 polarized = core%includes_polarization ()
              end if
              call setup_interaction_qn_index (int, term%config%data, &
                   qn_config, n_sub, polarized)
           end associate
        class default
           call int%init_qn_index ()
        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 :: init_from_process => term_instance_init_from_process
 <<Instances: procedures>>=
   subroutine term_instance_init_from_process (term_instance, &
          process, i, pcm_instance, sf_chain)
     class(term_instance_t), intent(inout), target :: term_instance
     type(process_t), intent(in), target :: process
     integer, intent(in) :: i
     class(pcm_instance_t), intent(in), target :: pcm_instance
     type(sf_chain_t), intent(in), target :: sf_chain
     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
        term_instance%pcm_instance => pcm_instance
        term_instance%nlo_type = 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_kinematics (sf_chain, &
             process%get_beam_config_ptr (), &
             process%get_phs_config (i_component), &
             requires_extended_sf)
        call term_instance%init (process, i, &
             real_finite = process%component_is_real_finite (i_component))
        select type (phs => term_instance%k_term%phs)
        type is (phs_fks_t)
           call term_instance%set_emitter (process%get_pcm_ptr ())
           call term_instance%setup_fks_kinematics (process%get_var_list_ptr (), &
                process%get_beam_config_ptr ())
        end select
        call term_instance%set_threshold (process%get_pcm_ptr ())
        call term_instance%setup_expressions (process%get_meta (), process%get_config ())
     end if
   end subroutine term_instance_init_from_process
 
 @ %def term_instance_init_from_process
 @ Initialize the seed-kinematics configuration.  All subobjects are
 allocated explicitly.
 <<Instances: term instance: TBP>>=
   procedure :: setup_kinematics => term_instance_setup_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_setup_kinematics (term, sf_chain, &
      beam_config, phs_config, extended_sf)
     class(term_instance_t), intent(inout) :: term
     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
     logical, intent(in) :: extended_sf
     select type (config => term%pcm_instance%config)
     type is (pcm_nlo_t)
        call term%k_term%init_sf_chain (sf_chain, beam_config, &
             extended_sf = config%has_pdfs .and. extended_sf)
     class default
        call term%k_term%init_sf_chain (sf_chain, beam_config)
     end select
     !!! Add one for additional Born matrix element
     call term%k_term%init_phs (phs_config)
     call term%k_term%set_nlo_info (term%nlo_type)
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        call phs%allocate_momenta (phs_config, &
             .not. (term%nlo_type == NLO_REAL))
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           call config%region_data%init_phs_identifiers (phs%phs_identifiers)
           !!! The triple select type pyramid of doom
           select type (pcm_instance => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              if (allocated (pcm_instance%real_kinematics%alr_to_i_phs)) &
                   call config%region_data%set_alr_to_i_phs (phs%phs_identifiers, &
                        pcm_instance%real_kinematics%alr_to_i_phs)
           end select
        end select
     end select
   end subroutine term_instance_setup_kinematics
 
 @ %def term_instance_setup_kinematics
 @
 <<Instances: term instance: TBP>>=
   procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_setup_fks_kinematics (term, var_list, beam_config)
     class(term_instance_t), intent(inout), target :: term
     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 => term%k_term%phs)
     type is (phs_fks_t)
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           select type (pcm_instance => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              call config%setup_phs_generator (pcm_instance, &
                   phs%generator, phs%config%sqrts, mode, singular_jacobian)
              if (beam_config%has_structure_function ()) then
                 pcm_instance%isr_kinematics%isr_mode = SQRTS_VAR
              else
                 pcm_instance%isr_kinematics%isr_mode = SQRTS_FIXED
              end if
              if (debug_on) call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_instance%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 (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           associate (settings => config%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
-@ Setup seed kinematics, starting from the MC parameter set given as
+@ 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, mci_work, phs_channel, success)
     class(term_instance_t), intent(inout), target :: term
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     logical, intent(out) :: success
     call term%k_term%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_radiation_kinematics => term_instance_evaluate_radiation_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_radiation_kinematics (term, x)
     class(term_instance_t), intent(inout) :: term
     real(default), dimension(:), intent(in) :: x
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) &
              call term%k_term%evaluate_radiation_kinematics (x)
     end select
   end subroutine term_instance_evaluate_radiation_kinematics
 
 @ %def term_instance_evaluate_radiation_kinematics
 @
 <<Instances: term instance: TBP>>=
   procedure :: compute_xi_ref_momenta => term_instance_compute_xi_ref_momenta
 <<Instances: procedures>>=
   subroutine term_instance_compute_xi_ref_momenta (term)
     class(term_instance_t), intent(inout) :: term
     select type (pcm => term%pcm_instance%config)
     type is (pcm_nlo_t)
        call term%k_term%compute_xi_ref_momenta (pcm%region_data, term%nlo_type)
     end select
   end subroutine term_instance_compute_xi_ref_momenta
 
 @ %def term_instance_compute_xi_ref_momenta
 @
 <<Instances: term instance: TBP>>=
   procedure :: generate_fsr_in => term_instance_generate_fsr_in
 <<Instances: procedures>>=
   subroutine term_instance_generate_fsr_in (term)
     class(term_instance_t), intent(inout) :: term
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        call phs%generate_fsr_in ()
     end select
   end subroutine term_instance_generate_fsr_in
 
 @ %def term_instance_generate_fsr_in
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_projections => term_instance_evaluate_projections
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_projections (term)
     class(term_instance_t), intent(inout) :: term
     if (term%k_term%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_instance => term%pcm_instance)
        type is (pcm_instance_nlo_t)
           call term%k_term%threshold_projection (pcm_instance, term%nlo_type)
        end select
     end if
   end subroutine term_instance_evaluate_projections
 
 @ %def term_instance_evaluate_projections
 @
 <<Instances: term instance: TBP>>=
   procedure :: redo_sf_chain => term_instance_redo_sf_chain
 <<Instances: procedures>>=
   subroutine term_instance_redo_sf_chain (term, mci_work, phs_channel)
     class(term_instance_t), intent(inout) :: term
     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 ()
        associate (k => term%k_term)
           sf_channel = k%phs%config%get_sf_channel (phs_channel)
           call k%sf_chain%compute_kinematics (sf_channel, x)
           deallocate (x)
        end associate
     end if
   end subroutine term_instance_redo_sf_chain
 
 @ %def term_instance_redo_sf_chain
 @ Inverse: recover missing parts of the kinematics, given a complete
 set of seed momenta.  Select a channel and reconstruct the MC parameter set.
 <<Instances: term instance: TBP>>=
   procedure :: recover_mcpar => term_instance_recover_mcpar
 <<Instances: procedures>>=
   subroutine term_instance_recover_mcpar (term, mci_work, phs_channel)
     class(term_instance_t), intent(inout), target :: term
     type(mci_work_t), intent(inout) :: mci_work
     integer, intent(in) :: phs_channel
     call term%k_term%recover_mcpar (mci_work, phs_channel, term%p_seed)
   end subroutine term_instance_recover_mcpar
 
 @ %def term_instance_recover_mcpar
 @ Part of [[recover_mcpar]], separately accessible.  Reconstruct all
 kinematics data in the structure-function chain instance.
 <<Instances: term instance: TBP>>=
   procedure :: recover_sfchain => term_instance_recover_sfchain
 <<Instances: procedures>>=
   subroutine term_instance_recover_sfchain (term, channel)
     class(term_instance_t), intent(inout), target :: term
     integer, intent(in) :: channel
     call term%k_term%recover_sfchain (channel, term%p_seed)
   end subroutine term_instance_recover_sfchain
 
 @ %def term_instance_recover_sfchain
 @ 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, skip_term, success)
     class(term_instance_t), intent(inout) :: term
     integer, intent(in), optional :: skip_term
     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 (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0) then
        call term%k_term%evaluate_radiation (term%p_seed, p, success)
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           if (config%dalitz_plot%active) then
              if (term%k_term%emitter > term%k_term%n_in) then
                 if (p(term%k_term%emitter)**2 > tiny_07) &
                      call config%register_dalitz_plot (term%k_term%emitter, p)
              end if
           end if
        end select
     else if (is_subtraction_component (term%k_term%emitter, term%nlo_type)) then
        call term%k_term%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)
     class(term_instance_t), intent(inout) :: term
     integer :: n_in
     n_in = term%k_term%n_in
     call term%k_term%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.)
        term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.)
     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.
 <<Instances: term instance: TBP>>=
   procedure :: compute_other_channels => &
        term_instance_compute_other_channels
 <<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.
 <<Instances: term instance: TBP>>=
   procedure :: return_beam_momenta => term_instance_return_beam_momenta
 <<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
 @
 <<Instances: term instance: TBP>>=
   procedure :: apply_real_partition => term_instance_apply_real_partition
 <<Instances: procedures>>=
   subroutine term_instance_apply_real_partition (term, process)
     class(term_instance_t), intent(inout) :: term
     type(process_t), intent(in) :: process
     real(default) :: f, sqme
     integer :: i_component
     integer :: i_amp, n_amps
     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. term%k_term%emitter < 0
        if (is_subtraction) return
        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
           sqme = real (term%connected%trace%get_matrix_element ( &
                term%connected%trace%get_qn_index (i_amp, i_sub = 0)))
           if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition")
           select type (pcm => term%pcm_instance%config)
           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 (i_amp, 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_lorentz_transformation => term_instance_get_lorentz_transformation
 <<Instances: procedures>>=
   function term_instance_get_lorentz_transformation (term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(term_instance_t), intent(in) :: term
     lt = term%k_term%phs%get_lorentz_transformation ()
   end function term_instance_get_lorentz_transformation
 
 @ %def term_instance_get_lorentz_transformation
 @
 <<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, pcm)
     class(term_instance_t), intent(inout) :: term
     class(pcm_t), intent(in) :: pcm
     integer :: i_phs
     logical :: set_emitter
     select type (pcm)
     type is (pcm_nlo_t)
        !!! Without resonances, i_alr = i_phs
        i_phs = term%config%i_term
        term%k_term%i_phs = term%config%i_term
        select type (phs => term%k_term%phs)
        type is (phs_fks_t)
           set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL
           if (set_emitter) then
              term%k_term%emitter = phs%phs_identifiers(i_phs)%emitter
              select type (pcm => term%pcm_instance%config)
              type is (pcm_nlo_t)
                 if (allocated (pcm%region_data%i_phs_to_i_con)) &
                    term%k_term%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
 @
 <<Instances: term instance: TBP>>=
   procedure :: set_threshold => term_instance_set_threshold
 <<Instances: procedures>>=
   subroutine term_instance_set_threshold (term, pcm)
     class(term_instance_t), intent(inout) :: term
     class(pcm_t), intent(in) :: pcm
     select type (pcm)
     type is (pcm_nlo_t)
        term%k_term%threshold = pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD
     class default
        term%k_term%threshold = .false.
     end select
   end subroutine term_instance_set_threshold
 
 @ %def term_instance_set_threshold
 @ 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 quantum numbers mask of the incoming particle
 <<Instances: term instance: TBP>>=
   procedure :: setup_event_data => term_instance_setup_event_data
 <<Instances: procedures>>=
   subroutine term_instance_setup_event_data (term, core, model)
     class(term_instance_t), intent(inout), target :: term
     class(prc_core_t), intent(in) :: core
     class(model_data_t), intent(in), target :: model
     integer :: n_in
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
     n_in = term%int_hard%get_n_in ()
     allocate (mask_in (n_in))
     mask_in = term%k_term%sf_chain%get_out_mask ()
     call setup_isolated (term%isolated, core, model, mask_in, term%config%col)
     call setup_connected (term%connected, term%isolated, term%nlo_type)
  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
      call isolated%setup_square_matrix (core, model, mask, color)
      call isolated%setup_square_flows (core, model, mask)
    end subroutine setup_isolated
 
    subroutine setup_connected (connected, isolated, nlo_type)
      type(connected_state_t), intent(inout), target :: connected
      type(isolated_state_t), intent(in), target :: isolated
      integer :: nlo_type
      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 don't 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, n_sub = 0, &
           is_polarized = .false.)
      call connected%setup_connected_flows (isolated)
      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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           if (debug_on) call msg_debug2 (D_SUBTRACTION, &
                "term_instance_evaluate_color_correlations: " // &
                "use_internal_color_correlations:", &
                config%settings%use_internal_color_correlations)
           if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%fac_scale)
 
           do i_flv_born = 1, config%region_data%n_flv_born
              select case (term%nlo_type)
              case (NLO_REAL)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      pcm_instance%real_sub%sqme_born (i_flv_born), &
                      pcm_instance%real_sub%sqme_born_color_c (:, :, i_flv_born))
              case (NLO_MISMATCH)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      pcm_instance%soft_mismatch%sqme_born (i_flv_born), &
                      pcm_instance%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 (config, i_flv_born, &
                      -one, pcm_instance%virtual%sqme_color_c (:, :, 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
       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
          n_offset = 0
          if (term%nlo_type == NLO_VIRTUAL) then
             n_offset = 1
          else if (pcm%has_pdfs .and. term%is_subtraction ()) 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)
       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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           do i_flv_born = 1, config%region_data%n_flv_born
              select case (term%nlo_type)
              case (NLO_REAL)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      pcm_instance%real_sub%sqme_born (i_flv_born), &
                      pcm_instance%real_sub%sqme_born_charge_c (:, :, i_flv_born))
              case (NLO_MISMATCH)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      pcm_instance%soft_mismatch%sqme_born (i_flv_born), &
                      pcm_instance%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born))
              case (NLO_VIRTUAL)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      -one, pcm_instance%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
       integer, 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) = sign (1, flv_born%flst(1:flv_born%n_in))
          sigma(flv_born%n_in + 1: ) = -sign (1, flv_born%flst(flv_born%n_in + 1: ))
       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_hel, i_sub, i_emitter, emitter
+    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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        if (pcm_instance%real_sub%requires_spin_correlations () &
             .and. term%nlo_type == NLO_REAL) then
           select type (core)
           type is (prc_openloops_t)
              select type (config => pcm_instance%config)
              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 (config%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, config%region_data%n_emitters
                       emitter = config%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_instance%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, alpha_s_sub, alpha_qed_sub)
     class(term_instance_t), intent(inout) :: term
     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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           if (term%connected%has_matrix) then
              allocate (sqme (config%get_n_alr ()))
           else
              allocate (sqme (1))
           end if
           sqme = zero
           select type (phs => term%k_term%phs)
           type is (phs_fks_t)
              call pcm_instance%set_real_and_isr_kinematics &
                   (phs%phs_identifiers, term%k_term%phs%get_sqrts ())
              if (term%k_term%emitter < 0) then
                 call pcm_instance%set_subtraction_event ()
                 do i_phs = 1, config%region_data%n_phs
                    emitter = phs%phs_identifiers(i_phs)%emitter
                    call pcm_instance%real_sub%compute (emitter, &
                         i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme)
                 end do
              else
                 call pcm_instance%set_radiation_event ()
                 emitter = term%k_term%emitter; i_phs = term%k_term%i_phs
                 do i = 1, term%connected%trace%get_qn_index_n_flv ()
                    pcm_instance%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_instance%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 (config => term%pcm_instance%config)
     type is (pcm_nlo_t)
        is_subtraction = term%k_term%emitter < 0
        if (term%connected%has_matrix) &
            call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
                 config%get_qn (is_subtraction), &
                 config%region_data%get_flavor_indices (is_subtraction), &
                 term%connected%matrix)
        if (term%connected%has_flows) &
             call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
                  config%get_qn (is_subtraction), &
                  config%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) :: 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%ren_scale
-        print *, 'fac_scale: ', term%fac_scale
-        print *, 'Ellis-Sexton scale:', term%es_scale
-     end if
-     select type (config => term%pcm_instance%config)
-     type is (pcm_nlo_t)
-        select type (pcm_instance => term%pcm_instance)
-        type is (pcm_instance_nlo_t)
-           select case (char (config%region_data%regions(1)%nlo_correction_type))
-           case ("QCD")
-             alpha_coupling = alpha_s
-             if (debug2_active (D_VIRTUAL)) print *, 'alpha_s: ', alpha_coupling
-           case ("EW")
-              alpha_coupling = alpha_qed
-              if (debug2_active (D_VIRTUAL)) print *, 'alpha_qed: ', alpha_coupling
-           end select
-           allocate (p_born (config%region_data%n_legs_born))
-           if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
-              p_born = pcm_instance%real_kinematics%p_born_onshell%get_momenta(1)
-           else
-              p_born = term%int_hard%get_momenta ()
-           end if
-           call pcm_instance%set_momenta_and_scales_virtual &
-                (p_born, term%ren_scale, term%fac_scale, term%es_scale)
-           select type (pcm_instance => term%pcm_instance)
-           type is (pcm_instance_nlo_t)
-              associate (virtual => pcm_instance%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_instance%compute_sqme_virt (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), &
-                     config%get_qn (.true.), &
-                     remove_duplicates_from_int_array ( &
-                     config%region_data%get_flavor_indices (.true.)), &
-                     term%connected%matrix)
-           if (term%connected%has_flows) &
-                call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
-                     config%get_qn (.true.), &
-                     remove_duplicates_from_int_array ( &
-                     config%region_data%get_flavor_indices (.true.)), &
-                     term%connected%flows)
-        end select
-     end select
+    class(term_instance_t), intent(inout) :: term
+    real(default), intent(in) :: alpha_s, alpha_qed
+    real(default) :: 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%ren_scale
+       print *, 'fac_scale: ', term%fac_scale
+       print *, 'Ellis-Sexton scale:', term%es_scale
+    end if
+    select type (config => term%pcm_instance%config)
+    type is (pcm_nlo_t)
+       select type (pcm_instance => term%pcm_instance)
+       type is (pcm_instance_nlo_t)
+          select case (char (config%region_data%regions(1)%nlo_correction_type))
+          case ("QCD")
+            alpha_coupling = alpha_s
+            if (debug2_active (D_VIRTUAL)) print *, 'alpha_s: ', alpha_coupling
+          case ("EW")
+             alpha_coupling = alpha_qed
+             if (debug2_active (D_VIRTUAL)) print *, 'alpha_qed: ', alpha_coupling
+          end select
+          allocate (p_born (config%region_data%n_legs_born))
+          if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
+             p_born = pcm_instance%real_kinematics%p_born_onshell%get_momenta(1)
+          else
+             p_born = term%int_hard%get_momenta ()
+          end if
+          call pcm_instance%set_momenta_and_scales_virtual &
+               (p_born, term%ren_scale, term%fac_scale, term%es_scale)
+          select type (pcm_instance => term%pcm_instance)
+          type is (pcm_instance_nlo_t)
+             associate (virtual => pcm_instance%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_instance%compute_sqme_virt (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), &
+                    config%get_qn (.true.), &
+                    remove_duplicates_from_int_array ( &
+                    config%region_data%get_flavor_indices (.true.)), &
+                    term%connected%matrix)
+          if (term%connected%has_flows) &
+               call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
+                    config%get_qn (.true.), &
+                    remove_duplicates_from_int_array ( &
+                    config%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
 @
 <<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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        call pcm_instance%compute_sqme_mismatch &
             (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 (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           if (term%connected%has_matrix) &
                call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%matrix)
           if (term%connected%has_flows) &
                call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%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)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_s
     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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        if (debug2_active (D_PROCESS_INTEGRATION)) then
           associate (n_flv => pcm_instance%dglap_remnant%reg_data%n_flv_born)
              print *, "size(sqme_born) = ", size (pcm_instance%dglap_remnant%sqme_born)
              call term%connected%trace%write ()
              do i_flv = 1, n_flv
                 print *, "i_flv = ", i_flv, ", n_flv = ", n_flv
                 print *, "sqme_born(i_flv) = ", pcm_instance%dglap_remnant%sqme_born(i_flv)
              end do
           end associate
        end if
        call pcm_instance%compute_sqme_dglap_remnant (alpha_s, &
             term%connected%has_matrix, sqme_dglap)
     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 (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           if (term%connected%has_matrix) &
                call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%matrix)
           if (term%connected%has_flows) &
                call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%flows)
        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.  (If we have an algorithm
 that uses rarrangement, it should evaluate [[k_term]] explicitly.)
 
 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)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in), pointer :: core
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction")
-    if (term%k_term%only_cm_frame .and. (.not. term%k_term%lab_is_cm())) then 
+    if (term%k_term%only_cm_frame .and. (.not. term%k_term%lab_is_cm())) then
          term%p_hard = term%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)
     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
     integer :: i
     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), &
             term%fac_scale, term%ren_scale, term%alpha_qcd_forced, &
             term%core_state)
     end do
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        call pcm_instance%set_fac_scale (term%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)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     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%ren_scale)
           if (allocated (core_state%threshold_data)) &
                call evaluate_threshold_parameters (core_state, core, term%k_term%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%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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        call pcm_instance%set_fac_scale (term%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 => term%pcm_instance)
              type is (pcm_instance_nlo_t)
                 if (term%k_term%emitter >= 0) then
                    call core%set_offshell_momenta &
                         (pcm%real_kinematics%p_real_cms%get_momenta(term%config%i_term))
                    leg = thr_leg (term%k_term%emitter)
                    call core%set_leg (leg)
                    call core%set_onshell_momenta &
                         (pcm%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term))
                 else
                    call core%set_leg (0)
                    call core%set_offshell_momenta &
                         (pcm%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}$ are color-correlated born matrix elements.
+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_spin_c, i_emitter
-    integer :: emitter
+    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
-          select type (core)
-          class is (prc_external_t)
-             call core%update_alpha_s (term%core_state, term%ren_scale)
-             call core%compute_sqme (i_flv, i_hel, term%p_hard, term%ren_scale, &
-                  sqme, bad_point)
-             call term%pcm_instance%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_instance%config%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%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
-               term%nlo_type == NLO_MISMATCH) then
-             sqme_color_c = zero
+          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_blha_t)
-                call core%compute_sqme_color_c_raw (i_flv, i_hel, &
-                     term%p_hard, term%ren_scale, sqme_color_c, bad_point)
-                call term%pcm_instance%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%ren_scale, sqme_color_c, bad_point)
+             class is (prc_external_t)
+                call core%update_alpha_s (term%core_state, term%ren_scale)
+                call core%compute_sqme (i_flv, i_hel, term%p_hard, term%ren_scale, &
+                     sqme, bad_point)
                 call term%pcm_instance%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
-             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))
+             n_pdf_off = 0
+             if (term%pcm_instance%config%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%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
+                  term%nlo_type == NLO_MISMATCH) then
+                sqme_color_c = zero
                 select type (core)
-                type is (prc_openloops_t)
-                   select type (config => term%pcm_instance%config)
-                   type is (pcm_nlo_t)
-                      do i_emitter = 1, config%region_data%n_emitters
-                         emitter = config%region_data%emitters(i_emitter)
-                         if (emitter > 0) then
-                            call core%compute_sqme_spin_c &
-                                 (i_flv, &
-                                 i_hel, &
-                                 emitter, &
-                                 term%p_hard, &
-                                 term%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
+                class is (prc_blha_t)
+                   call core%compute_sqme_color_c_raw (i_flv, i_hel, &
+                        term%p_hard, term%ren_scale, sqme_color_c, bad_point)
+                   call term%pcm_instance%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%ren_scale, sqme_color_c, bad_point)
+                   call term%pcm_instance%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 (config => term%pcm_instance%config)
+                      type is (pcm_nlo_t)
+                         do i_emitter = 1, config%region_data%n_emitters
+                            emitter = config%region_data%emitters(i_emitter)
+                            if (emitter > 0) then
+                               call core%compute_sqme_spin_c &
+                                    (i_flv, &
+                                    i_hel, &
+                                    emitter, &
+                                    term%p_hard, &
+                                    term%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
-                   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)
+                   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_instance%config%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%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
+    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
     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
-          select type (core)
-          class is (prc_external_t)
-             call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, &
-                  term%ren_scale, term%es_scale, &
-                  term%pcm_instance%config%blha_defaults%loop_method, &
-                  sqme_virt, bad_point)
-             call term%pcm_instance%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 (config => term%pcm_instance%config)
-          type is (pcm_nlo_t)
+          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_blha_t)
-                call core%compute_sqme_color_c_raw (i_flv, i_hel, &
-                     term%p_hard, term%ren_scale, &
-                     sqme_color_c, bad_point)
+             class is (prc_external_t)
+                call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, &
+                     term%ren_scale, term%es_scale, &
+                     term%pcm_instance%config%blha_defaults%loop_method, &
+                     sqme_virt, bad_point)
                 call term%pcm_instance%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%ren_scale, sqme_color_c, bad_point)
-                call term%pcm_instance%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
+             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 (config => term%pcm_instance%config)
+             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%ren_scale, &
+                        sqme_color_c, bad_point)
+                   call term%pcm_instance%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%ren_scale, sqme_color_c, bad_point)
+                   call term%pcm_instance%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
 [[k_term]] 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)
     class(term_instance_t), intent(inout) :: term
     call term%k_term%evaluate_sf_chain (term%fac_scale)
     call term%evaluate_scaled_sf_chains ()
     call term%isolated%evaluate_sf_chain (term%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)
     class(term_instance_t), intent(inout) :: term
     class(sf_rescale_t), allocatable :: sf_rescale
     if (.not. term%pcm_instance%config%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 => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              select type (sf_rescale)
              type is (sf_rescale_collinear_t)
                 call sf_rescale%set (pcm%real_kinematics%xi_tilde)
              end select
           end select
           call term%k_term%sf_chain%evaluate (term%fac_scale, sf_rescale)
           deallocate (sf_rescale)
        else if (term%k_term%emitter >= 0 .and. term%k_term%emitter <= term%k_term%n_in) then
           allocate (sf_rescale_real_t :: sf_rescale)
           select type (pcm => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              select type (sf_rescale)
              type is (sf_rescale_real_t)
                 call sf_rescale%set (pcm%real_kinematics%xi_tilde * &
                      pcm%real_kinematics%xi_max (term%k_term%i_phs), &
                      pcm%real_kinematics%y (term%k_term%i_phs))
              end select
           end select
           call term%k_term%sf_chain%evaluate (term%fac_scale, sf_rescale)
           deallocate (sf_rescale)
        else
           call term%k_term%sf_chain%evaluate (term%fac_scale)
        end if
     else if (term%nlo_type == NLO_DGLAP) then
        allocate (sf_rescale_dglap_t :: sf_rescale)
        select type (pcm => term%pcm_instance)
        type is (pcm_instance_nlo_t)
           select type (sf_rescale)
           type is (sf_rescale_dglap_t)
              call sf_rescale%set (pcm%isr_kinematics%z)
           end select
        end select
        call term%k_term%sf_chain%evaluate (term%fac_scale, 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:
 <<Instances: term instance: TBP>>=
   procedure :: get_fac_scale => term_instance_get_fac_scale
 <<Instances: procedures>>=
   function term_instance_get_fac_scale (term) result (fac_scale)
     class(term_instance_t), intent(in) :: term
     real(default) :: fac_scale
     fac_scale = term%fac_scale
   end function term_instance_get_fac_scale
 
 @ %def term_instance_get_fac_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
 @
 <<Instances: term instance: TBP>>=
   procedure :: reset_phs_identifiers => term_instance_reset_phs_identifiers
 <<Instances: procedures>>=
   subroutine term_instance_reset_phs_identifiers (term)
     class(term_instance_t), intent(inout) :: term
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        phs%phs_identifiers%evaluated = .false.
     end select
   end subroutine term_instance_reset_phs_identifiers
 
 @ %def term_instance_reset_phs_identifiers
 @ 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_boost_to_lab => term_instance_get_boost_to_lab
 <<Instances: procedures>>=
   function term_instance_get_boost_to_lab (term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(term_instance_t), intent(in) :: term
     lt = term%k_term%phs%get_lorentz_transformation ()
   end function term_instance_get_boost_to_lab
 
 @ %def term_instance_get_boost_to_lab
 @
 <<Instances: term instance: TBP>>=
   procedure :: get_boost_to_cms => term_instance_get_boost_to_cms
 <<Instances: procedures>>=
   function term_instance_get_boost_to_cms (term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(term_instance_t), intent(in) :: term
     lt = inverse (term%k_term%phs%get_lorentz_transformation ())
   end function term_instance_get_boost_to_cms
 
 @ %def term_instance_get_boost_to_cms
 @
 <<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}
 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 [[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 [[component]] subobjects determine the state of each component.
 
 The [[term]] subobjects are workspace for evaluating kinematics,
 matrix elements, cuts etc.
 
 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 ()
      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(term_instance_t), dimension(:), allocatable :: term
      type(mci_work_t), dimension(:), allocatable :: mci_work
      class(pcm_instance_t), allocatable :: pcm
      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, &
                            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) :: term
     type(var_list_t), pointer :: var_list
     integer :: i_born, i_real, i_real_fin
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init")
     instance%process => process
     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_instance (instance%pcm)
     call instance%pcm%link_config (pcm)
     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_instance each time.
        i_real_fin = process%get_associated_real_fin (1)
        if (.not. pcm%initialized) then
 !          i_born = pcm%get_i_core_nlo_type (BORN)
           i_born = pcm%get_i_core (pcm%i_born)
 !          i_real = pcm%get_i_core_nlo_type (NLO_REAL, include_sub = .false.)
 !          i_real = pcm%get_i_core_nlo_type (NLO_REAL)
           i_real = pcm%get_i_core (pcm%i_real)
           term = process%get_term_ptr (process%get_i_term (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_instance => instance%pcm)
        type is (pcm_instance_nlo_t)
           call pcm_instance%init_config (process%component_can_be_integrated (), &
                process%get_nlo_type_component (), process%get_sqrts (), i_real_fin, &
                process%get_model_ptr ())
        end select
     end select
     allocate (instance%term (process%get_n_terms ()))
     do i = 1, process%get_n_terms ()
        call instance%term(i)%init_from_process (process, i, instance%pcm, &
             instance%sf_chain)
     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%term)) then
        do i = 1, size (instance%term)
           call instance%term(i)%final ()
        end do
        deallocate (instance%term)
     end if
     call instance%pcm%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) :: 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%term%k_term%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%term(i)%k_term%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%term(j)%k_term%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%term(i_term_same)%k_term%phs)
                 call phs%set_lorentz_transformation &
                      (instance%term(i_term)%k_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%term(i_term_same)%k_term%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%term(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))
          if (associated (term%config)) then
             core => instance%process%get_core_term (i)
             call term%setup_event_data (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%term(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, skip_term)
     class(process_instance_t), intent(inout) :: instance
     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 (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)
                 if (instance%term(i_term(j))%k_term%new_seed) then
                    call instance%term(i_term(j))%compute_seed_kinematics &
                         (instance%mci_work(instance%i_mci), channel, success)
                    call instance%transfer_same_kinematics (i_term(j))
                 end if
                 if (.not. success)  exit
                 call instance%term(i_term(j))%evaluate_projections ()
                 call instance%term(i_term(j))%evaluate_radiation_kinematics &
                        (instance%mci_work(instance%i_mci)%get_x_process ())
                 call instance%term(i_term(j))%generate_fsr_in ()
                 call instance%term(i_term(j))%compute_xi_ref_momenta ()
              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 => instance%pcm)
        class is (pcm_instance_nlo_t)
           call pcm%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
     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%term(i_term)%recover_mcpar &
             (instance%mci_work(instance%i_mci), channel)
     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%term(i_term)%recover_sfchain (channel)
     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, skip_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), optional :: skip_term
     integer :: i
     logical :: success
     success = .true.
     if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
        do i = 1, size (instance%term)
           if (instance%term(i)%active) then
              call instance%term(i)%compute_hard_kinematics (skip_term, success)
              if (.not. success) exit
              !!! Ren scale is zero when this is commented out! Understand!
              if (instance%term(i)%nlo_type == NLO_REAL) &
                   call instance%term(i)%redo_sf_chain (instance%mci_work(instance%i_mci), &
                        instance%selected_channel)
           end if
        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
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) &
        call instance%term(i_term)%recover_seed_kinematics ()
   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 (config => instance%pcm%config)
       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 (config%settings%cut_all_real_sqmes) &
                     passed_real = passed_real .and. instance%term(i)%passed
                if (config%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
                instance%term(i)%es_scale = instance%term(i)%ren_scale
             else
                instance%term(i)%es_scale = es_scale
             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%term(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)
     class(process_instance_t), intent(inout) :: instance
     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))
             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)
                call term%evaluate_trace ()
                i_real_fin = instance%process%get_associated_real_fin (1)
                if (instance%process%uses_real_partition ()) &
                     call term%apply_real_partition (instance%process)
                if (term%config%i_component /= i_real_fin) then
                   if ((term%nlo_type == NLO_REAL .and. term%k_term%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 (has_pdfs)
                   if (term%nlo_type > BORN) then
                      if (.not. (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0)) then
                         select type (config => term%pcm_instance%config)
                         type is (pcm_nlo_t)
                            if (char (config%settings%nlo_correction_type) == "QCD" .or. &
                                 char (config%settings%nlo_correction_type) == "Full") &
                                 call term%evaluate_color_correlations (core_sub)
                            if (char (config%settings%nlo_correction_type) == "EW" .or. &
                                 char (config%settings%nlo_correction_type) == "Full") &
                                 call term%evaluate_charge_correlations (core_sub)
                         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 ()
                   if (term%nlo_type > BORN) then
                      select type (config => term%pcm_instance%config)
                      type is (pcm_nlo_t)
                         if (alpha_qed == -1 .and. (&
                              char (config%settings%nlo_correction_type) == "EW" .or. &
                              char (config%settings%nlo_correction_type) == "Full")) then
                            call msg_bug("Attempting to compute EW corrections with alpha_qed = -1")
                         end if
                      end select
                   end if
                   select case (term%nlo_type)
                   case (NLO_REAL)
                      call term%apply_fks (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)
                   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%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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_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_instance%real_sub%sqme_born(i_flv) = sqme
           case (NLO_MISMATCH)
              pcm_instance%soft_mismatch%sqme_born(i_flv) = sqme
           case (NLO_DGLAP)
              pcm_instance%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.
 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, has_pdfs)
     class(term_instance_t), intent(inout) :: term
     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_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        if (.not. has_pdfs) then
           pcm_instance%real_sub%sf_factors = one
           return
        end if
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           sf_chain_int => term%k_term%sf_chain%get_out_int_ptr ()
           associate (reg_data => config%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_instance, 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_instance, alr, em, factor_born, factor_real)
                       end do
                    end if
                 end if
              end do
           end associate
        end select
     end select
   contains
     subroutine set_factor (pcm_instance, alr, em, factor_born, factor_real)
       type(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
       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_instance%real_sub%sf_factors(alr, em) = factor
       case (NLO_DGLAP)
          pcm_instance%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 (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_instance => instance%pcm)
     type is (pcm_instance_nlo_t)
        if (allocated (pcm_instance%i_mci_to_real_component)) then
           call msg_warning ("i_mci_to_real_component already allocated - replace it")
           deallocate (pcm_instance%i_mci_to_real_component)
        end if
        allocate (pcm_instance%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_instance%i_mci_to_real_component (i_mci) = &
                      component%config%get_associated_real ()
              case (COMP_REAL_FIN)
                 pcm_instance%i_mci_to_real_component (i_mci) = &
                      component%config%get_associated_real_fin ()
              case (COMP_REAL_SING)
                 pcm_instance%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 => instance%pcm)
     type is (pcm_instance_nlo_t)
        associate (term => instance%term(i_term))
           core => instance%process%get_core_term (i_term)
           if (is_subtraction) then
              call pcm%set_subtraction_event ()
           else
              call pcm%set_radiation_event ()
           end if
           call term%int_hard%set_momenta (pcm%get_momenta &
                (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)
           call term%evaluate_trace ()
           if (term%is_subtraction ()) then
              call term%set_sf_factors (has_pdfs)
              select type (config => term%pcm_instance%config)
              type is (pcm_nlo_t)
                 if (char (config%settings%nlo_correction_type) == "QCD" .or. &
                      char (config%settings%nlo_correction_type) == "Full") &
                      call term%evaluate_color_correlations (core)
                 if (char (config%settings%nlo_correction_type) == "EW" .or. &
                      char (config%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 (core%get_alpha_s (term%core_state), 0._default)
           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
     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)
     if (recover_phs) then
        call instance%recover_mcpar (i_term)
        call instance%recover_beam_momenta (i_term)
        call instance%compute_seed_kinematics (i_term)
        call instance%compute_hard_kinematics (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 ()
     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%term(i_term_base)%k_term)
               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%term(i)%k_term%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))
        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 &
             (instance%mci_work(i_component), 1, success)
        call instance%term(i_term)%evaluate_radiation_kinematics &
               (instance%mci_work(instance%i_mci)%get_x_process ())
        call instance%term(i_term)%compute_hard_kinematics (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 => instance%pcm)
     type is (pcm_instance_nlo_t)
        i_real = pcm%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)
     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
     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))
   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%term(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%term(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%term(i_term)%k_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%term)
        call pacify (instance%term(i)%k_term%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%term(1)%k_term%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%term(1)%k_term%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/fks/fks.nw
===================================================================
--- trunk/src/fks/fks.nw	(revision 8444)
+++ trunk/src/fks/fks.nw	(revision 8445)
@@ -1,9753 +1,9862 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: matrix elements and process libraries
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{FKS Subtraction Scheme}
 \includemodulegraph{fks}
 
 The code in this chapter implements the FKS subtraction scheme for use
 with \whizard.
 
 These are the modules:
 \begin{description}
 \item[fks\_regions]
   Given a process definition, identify singular regions in the
   associated phase space.
 \item[virtual]
   Handle the virtual correction matrix element.
 \item[real\_subtraction]
   Handle the real-subtraction matrix element.
 \item[nlo\_data]
   Manage the subtraction objects.
 \end{description}
 
 This chapter deals with next-to-leading order contributions to cross sections.
 Basically, there are three major issues to be adressed: The creation
 of the $N+1$-particle flavor structure, the construction of the
 $N+1$-particle phase space and the actual calculation of the real- and
 virtual-subtracted matrix elements. The first is dealt with using the
 [[auto_components]] class, and it will be shown that the second
 and third issue are connected in FKS subtraction.
 
 \section{Brief outline of FKS subtraction}
 {\em In the current state, this discussion is only concerned with
   lepton collisions. For hadron collisions, renormalization of parton
   distributions has to be taken into account. Further, for QCD
   corrections, initial-state radiation is necessarily
   present.}
 
 The aim is to calculate the next-to-leading order cross section
 according to
 \begin{equation*}
   d\sigma_{\rm{NLO}} = \mathcal{B} + \mathcal{V} +
   \mathcal{R}d\Phi_{\rm{rad}}.
 \end{equation*}
 Analytically, the divergences, in terms of poles in the complex
 quantity $\varepsilon = 2-d/2$, cancel. However, this is in general
 only valid in an arbitrary, complex number of dimensions. This is,
 roughly, the content of the KLN-theorem. \whizard, as any
 other numerical program, is confined to four dimensions. We will
 assume that the KLN-theorem is valid and that there exist subtraction
 terms $\mathcal{C}$ such that
 \begin{equation*}
   d\sigma_{\rm{NLO}} = \mathcal{B} + \underbrace{\mathcal{V} +
     \mathcal{C}}_{\text{finite}} + \underbrace{\mathcal{R} -
     \mathcal{C}}_{\text{finite}},
 \end{equation*}
 i.e. the subtraction terms correspond to the divergent limits of the
 real and virtual matrix element.
 
 Because $\mathcal{C}$ subtracts the divergences of $\mathcal{R}$ as
 well as those of $\mathcal{V}$, it suffices to consider one of them,
 so we focus on $\mathcal{R}$. For this purpose, $\mathcal{R}$ is
 rewritten as
 \begin{equation*}
   \mathcal{R} = \frac{1}{\xi^2}\frac{1}{1-y} \left(\xi^2
     (1-y)\mathcal{R}\right) =
   \frac{1}{\xi^2}\frac{1}{1-y}\tilde{\mathcal{R}},
 \end{equation*}
 with $\xi = \left(2k_{\rm{rad}}^0\right)/\sqrt{s}$ and $y =
 \cos\theta$, where $k_{\rm{rad}}^0$ denotes the energy of the radiated
 parton and $\theta$ is the angle between emitter and radiated
 parton. $\tilde{\mathcal{R}}$ is finite, therefore the whole
 singularity structure is contained in the prefactor
 $\xi^{-2}(1-y)^{-1}$. Combined with the $d$-dimensional phase space
 element,
 \begin{equation*}
   \frac{d^{d-1}k}{2k^0(2\pi)^{d-1}} =
   \frac{s^{1-\varepsilon}}{(4\pi)^{d-1}}\xi^{1-2\varepsilon}\left(1-y^2\right)^{-\varepsilon}
   d\xi dy d\Omega^{d-2},
 \end{equation*}
 this yields
 \begin{equation*}
   d\Phi_{\rm{rad}} \mathcal{R} = dy (1-y)^{-1-\varepsilon} d\xi
   \xi^{-1-2\varepsilon} \tilde{R}.
 \end{equation*}
 This can further be rewritten in terms of plus-distributions,
 \begin{align*}
 \xi^{-1-2\varepsilon} &= -\frac{1}{2\varepsilon}\delta(\xi) +
 \left(\frac{1}{\xi}\right)_+ -
 2\varepsilon\left(\frac{\log\xi}{\xi}\right)_+ +
 \mathcal{O}(\varepsilon^2),\\
 (1-y)^{-1-\varepsilon} &= -\frac{2^{-\varepsilon}}{\varepsilon}
 \delta(1-y) + \left(\frac{1}{1-y}\right)_+ - \varepsilon
 \left(\frac{1}{1-y}\right)_+\log(1-y) + \mathcal{O}(\varepsilon^2),
 \end{align*}
 (imagine that all this is written inside of integrals, which are
 spared for ease of notation) such that
 \begin{align*}
 d\Phi_{\rm{rad}} \mathcal{R} &= -\frac{1}{2\varepsilon} dy
 (1-y)^{-1-\varepsilon}\tilde{R} (0,y) -
 d\xi\left[\frac{2^{-\varepsilon}}{\varepsilon}\left(\frac{1}{\xi}\right)_+
   - 2\left(\frac{\log\xi}{\xi}\right)_+\right] \tilde{R}(\xi,1) \\
                               &+ dy d\xi \left(\frac{1}{\xi}\right)_+
                               \left(\frac{1}{1-y}\right)_+
                               \tilde{R}(\xi, y) +
                               \mathcal{O}(\varepsilon).\\
 \end{align*}
 The summand in the second line is of order $\mathcal{O}(1)$ and is the
 only one to reproduce $\mathcal{R}(\xi,y)$. It thus constitutes the
 sum of the real matrix element and the corresponding counterterms.
 The first summand consequently consists of the subtraction terms to
 the virtual matrix elements. Above formula thus allows to calculate
 all quantities to render the matrix elements finite.
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Identifying singular regions}
 In the FKS subtraction scheme, the phase space is decomposed into
 disjoint singular regions, such that
 \begin{equation}
 \label{eq:S_complete}
   \sum_i \mathcal{S}_i + \sum_{ij}\mathcal{S}_{ij} = 1.
 \end{equation}
 The quantities $\mathcal{S}_i$ and $\mathcal{S}_{ij}$ are functions of
 phase space corresponding to a pair of particles indices which can
 make up a divergent phase space region. We call such an index pair a
 fundamental tuple. For example, the process $e^+ \, e^- \rightarrow u
 \, \bar{u} \, g$ has two singular regions, $(3,5)$ and $(4,5)$,
 indicating that the gluon can be soft or collinear with respect to
 either the quark or the anti-quark. Therefore, the functions $S_{ij}$
 have to be chosen in such a way that their contribution makes up most
 of \eqref{eq:S_complete} in phase-space configurations where
 (final-state) particle $j$ is collinear to particle $i$ or/and
 particle $j$ is soft. The functions $S_i$ is the corresponding
 quantity for initial-state divergences.
 
 As a singular region we understand the collection of real flavor
 structures associated with an emitter and a list of all possible
 fundamental tuples. As an example, consider the process $e^+ \, e^-
 \rightarrow u \, \bar{u} \, g$. At next-to-leading order, processes
 with an additionally radiated particle have to be considered. In this
 case, these are $e^+ \, e^- \rightarrow u \, \bar{u}, \, g \, g$,
 and $e^+ \, e^- \rightarrow u \, \bar{u} \, u \, \bar{u}$ (or the same
 process with any other quark). Table \ref{table:singular regions} sums
 up all possible singular regions for this problem.
 \begin{table}
 \begin{tabular}{|c|c|c|c|}
   \hline
   \texttt{alr} & \texttt{flst\_alr} & \texttt{emitter} &
   \texttt{ftuple\_list}\\ \hline
   1 & [-11,11,2,-2,21,21] & 3 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
   2 & [-11,11,2,-2,21,21] & 4 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
   3 & [-11,11,2,-2,21,21] & 5 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
   4 & [-11,11,2,-2,2,-2]  & 5 & {(3,4), (3,6), (4,5), (5,6)} \\
   \hline
 \end{tabular}
 \caption{List of singular regions. The particles are represented by
   their PDG codes. The third column contains the emitter for the
   specific singular region. For the process involving an additional
   gluon, the gluon can either be emitted from one of the quarks or
   from the first gluon. Each emitter yields the same list of
   fundamental tuples, five in total. The last singular region
   corresponds to the process where the gluon splits up into two
   quarks. As the matrix element for this process has no information
   on which quarks originate from a gluon splitting, there are ftuples
   for all the quark pairs and not just those involving the emitter.}
 \label{table:singular regions}
 \end{table}
 \\
 \begin{table}
 \begin{tabular}{|c|c|c|c|}
   \hline
   \texttt{alr} & \texttt{ftuple} & \texttt{emitter} &
   \texttt{flst\_alr} \\ \hline
   1 & $(3,5)$ & 5 & [-11,11,-2,21,2,21] \\ \hline
   2 & $(4,5)$ & 5 & [-11,11,2,21,-2,21] \\ \hline
   3 & $(3,6)$ & 5 & [-11,11,-2,21,2,21] \\ \hline
   4 & $(4,6)$ & 5 & [-11,11,2,21,-2,21] \\ \hline
   5 & $(5,6)$ & 5 & [-11,11,2,-2,21,21] \\ \hline
   6 & $(5,6)$ & 5 & [-11,11,2,-2,2,-2] \\ \hline
 \end{tabular}
 \caption{Initial list of singular regions}
 \label{table:ftuples and flavors}
 \end{table}
 Thus, during the preparation of a NLO-calculation, the possible
 singular regions have to be identified. [[fks_regions.f90]] deals
 with this issue.
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{FKS Regions}
 <<[[fks_regions.f90]]>>=
 <<File header>>
 
 module fks_regions
 
 <<Use kinds>>
   use format_utils, only: write_separator
   use numeric_utils
   use string_utils, only: str
   use io_units
   use os_interface
 <<Use strings>>
 <<Use debug>>
   use constants
   use permutations
   use diagnostics
   use flavors
   use process_constants
   use lorentz
   use pdg_arrays
   use models
   use physics_defs
   use resonances, only: resonance_contributors_t, resonance_history_t
   use phs_fks, only: phs_identifier_t, check_for_phs_identifier
 
   use nlo_data
 
 <<Standard module head>>
 
 <<fks regions: public>>
 
 <<fks regions: parameters>>
 
 <<fks regions: types>>
 
 <<fks regions: interfaces>>
 
 contains
 
 <<fks regions: procedures>>
 
 end module fks_regions
 @ %def fks_regions
 @ There are three fundamental splitting types: $q \rightarrow qg$, $g \rightarrow gg$ and
 $g \rightarrow qq$ for FSR and additionally $q \rightarrow gq$ for ISR which is different
 from $q \rightarrow qg$ by which particle enters the hard process.
 <<fks regions: parameters>>=
   integer, parameter :: UNDEFINED_SPLITTING = 0
   integer, parameter :: F_TO_FV = 1
   integer, parameter :: V_TO_VV = 2
   integer, parameter :: V_TO_FF = 3
   integer, parameter :: F_TO_VF = 4
 
 @
 @ We group the indices of the emitting and the radiated particle in
 the [[ftuple]]-object.
 <<fks regions: public>>=
   public :: ftuple_t
 <<fks regions: types>>=
   type :: ftuple_t
     integer, dimension(2) :: ireg = [-1,-1]
     integer :: i_res = 0
     integer :: splitting_type
     logical :: pseudo_isr = .false.
   contains
   <<fks regions: ftuple: TBP>>
   end type ftuple_t
 
 @ %def ftuple_t
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure ftuple_assign
   end interface
 
   interface operator(==)
      module procedure ftuple_equal
   end interface
 
   interface operator(>)
      module procedure ftuple_greater
   end interface
 
   interface operator(<)
      module procedure ftuple_less
   end interface
 
 <<fks regions: procedures>>=
   pure subroutine ftuple_assign (ftuple_out, ftuple_in)
     type(ftuple_t), intent(out) :: ftuple_out
     type(ftuple_t), intent(in) :: ftuple_in
     ftuple_out%ireg = ftuple_in%ireg
     ftuple_out%i_res = ftuple_in%i_res
     ftuple_out%splitting_type = ftuple_in%splitting_type
     ftuple_out%pseudo_isr = ftuple_in%pseudo_isr
   end subroutine ftuple_assign
 
 @ %def ftuple_assign
 @
 <<fks regions: procedures>>=
   elemental function ftuple_equal (f1, f2) result (value)
     logical :: value
     type(ftuple_t), intent(in) :: f1, f2
     value = all (f1%ireg == f2%ireg) .and. f1%i_res == f2%i_res &
          .and. f1%splitting_type == f2%splitting_type &
          .and. (f1%pseudo_isr .eqv. f2%pseudo_isr)
   end function ftuple_equal
 
 @ %def ftuple_equal
 @
 <<fks regions: procedures>>=
   elemental function ftuple_equal_ireg (f1, f2) result (value)
     logical :: value
     type(ftuple_t), intent(in) :: f1, f2
     value = all (f1%ireg == f2%ireg)
   end function ftuple_equal_ireg
 
 @ %def ftuple_equal_ireg
 @
 <<fks regions: procedures>>=
   elemental function ftuple_greater (f1, f2) result (greater)
     logical :: greater
     type(ftuple_t), intent(in) :: f1, f2
     if (f1%ireg(1) == f2%ireg(1)) then
        greater = f1%ireg(2) > f2%ireg(2)
     else
        greater = f1%ireg(1) > f2%ireg(1)
     end if
   end function ftuple_greater
 
 @ %def ftuple_greater
 @
 <<fks regions: procedures>>=
   elemental function ftuple_less (f1, f2) result (less)
     logical :: less
     type(ftuple_t), intent(in) :: f1, f2
     if (f1%ireg(1) == f2%ireg(1)) then
        less = f1%ireg(2) < f2%ireg(2)
     else
        less = f1%ireg(1) < f2%ireg(1)
     end if
   end function ftuple_less
 
 @ %def ftuple_less
 <<fks regions: procedures>>=
   subroutine ftuple_sort_array (ftuple_array, equivalences)
     type(ftuple_t), intent(inout), dimension(:), allocatable :: ftuple_array
     logical, intent(inout), dimension(:,:), allocatable :: equivalences
     type(ftuple_t) :: ftuple_tmp
     logical, dimension(:), allocatable :: eq_tmp
     integer :: i1, i2, n
     n = size (ftuple_array)
     allocate (eq_tmp (n))
     do i1 = 2, n
        i2 = i1
        do while (ftuple_array(i2 - 1) > ftuple_array(i2))
           ftuple_tmp = ftuple_array(i2 - 1)
           eq_tmp = equivalences(i2, :)
           ftuple_array(i2 - 1) = ftuple_array(i2)
           ftuple_array(i2) = ftuple_tmp
           equivalences(i2 - 1, :) = equivalences(i2, :)
           equivalences(i2, :) = eq_tmp
           i2 = i2 - 1
           if (i2 == 1) exit
        end do
     end do
   end subroutine ftuple_sort_array
 
 @ %def ftuple_sort_array
 @
 <<fks regions: ftuple: TBP>>=
   procedure :: write => ftuple_write
 <<fks regions: procedures>>=
   subroutine ftuple_write (ftuple, unit, newline)
     class(ftuple_t), intent(in) :: ftuple
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: newline
     integer :: u
     logical :: nl
     u = given_output_unit (unit); if (u < 0) return
     nl = .true.; if (present(newline)) nl = newline
     if (all (ftuple%ireg > -1)) then
        if (ftuple%i_res > 0) then
           if (nl) then
              write (u, "(A1,I1,A1,I1,A1,I1,A1)") &
                  '(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')'
           else
              write (u, "(A1,I1,A1,I1,A1,I1,A1)", advance = "no") &
                  '(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')'
           end if
        else
           if (nl) then
              write (u, "(A1,I1,A1,I1,A1)") &
                   '(', ftuple%ireg(1), ',', ftuple%ireg(2), ')'
           else
              write (u, "(A1,I1,A1,I1,A1)", advance = "no") &
                   '(', ftuple%ireg(1), ',', ftuple%ireg(2), ')'
           end if
        end if
     else
        write (u, "(A)") "(Empty)"
     end if
   end subroutine ftuple_write
 
 @ %def ftuple_write
 @
 <<fks regions: procedures>>=
   function ftuple_string (ftuples, latex)
     type(string_t) :: ftuple_string
     type(ftuple_t), intent(in), dimension(:) :: ftuples
     logical, intent(in) :: latex
     integer :: i, nreg
     if (latex) then
        ftuple_string = var_str ("$\left\{")
     else
        ftuple_string = var_str ("{")
     end if
     nreg = size(ftuples)
     do i = 1, nreg
        if (ftuples(i)%i_res == 0) then
           ftuple_string = ftuple_string // var_str ("(") // &
                str (ftuples(i)%ireg(1)) // var_str (",") // &
                str (ftuples(i)%ireg(2)) // var_str (")")
        else
           ftuple_string = ftuple_string // var_str ("(") // &
                str (ftuples(i)%ireg(1)) // var_str (",") // &
                str (ftuples(i)%ireg(2)) // var_str (";") // &
                str (ftuples(i)%i_res) // var_str (")")
        end if
        if (ftuples(i)%pseudo_isr) ftuple_string = ftuple_string // var_str ("*")
        if (i < nreg) ftuple_string = ftuple_string // var_str (",")
     end do
     if (latex) then
        ftuple_string = ftuple_string // var_str ("\right\}$")
     else
        ftuple_string = ftuple_string // var_str ("}")
     end if
   end function ftuple_string
 
 @ %def ftuple_string
 @
 <<fks regions: ftuple: TBP>>=
   procedure :: get => ftuple_get
 <<fks regions: procedures>>=
   subroutine ftuple_get (ftuple, pos1, pos2)
     class(ftuple_t), intent(in) :: ftuple
     integer, intent(out) :: pos1, pos2
     pos1 = ftuple%ireg(1)
     pos2 = ftuple%ireg(2)
   end subroutine ftuple_get
 
 @ %def ftuple_get
 @
 <<fks regions: ftuple: TBP>>=
   procedure :: set => ftuple_set
 <<fks regions: procedures>>=
   subroutine ftuple_set (ftuple, pos1, pos2)
     class(ftuple_t), intent(inout) :: ftuple
     integer, intent(in) ::  pos1, pos2
     ftuple%ireg(1) = pos1
     ftuple%ireg(2) = pos2
   end subroutine ftuple_set
 
 @ %def ftuple_set
 @ Determines the splitting type for FSR. There are three different types of splittings
 relevant here: $g \to gg$ tagged [[V_TO_VV]], $g \to qq$ tagged [[V_TO_FF]] and
 $q \to qg$ tagged [[F_TO_FV]]. For FSR, there is no need to differentiate between
 $q \to qg$ and $q \to gq$ splittings.
 <<fks regions: ftuple: TBP>>=
   procedure :: determine_splitting_type_fsr => ftuple_determine_splitting_type_fsr
 <<fks regions: procedures>>=
   subroutine ftuple_determine_splitting_type_fsr (ftuple, flv, i, j)
     class(ftuple_t), intent(inout) :: ftuple
     type(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i, j
     associate (flst => flv%flst)
        if (is_vector (flst(i)) .and. is_vector (flst(j))) then
           ftuple%splitting_type = V_TO_VV
        else if (flst(i)+flst(j) == 0 &
              .and. is_fermion (flst(i))) then
           ftuple%splitting_type = V_TO_FF
        else if (is_fermion(flst(i)) .and. is_massless_vector (flst(j)) &
              .or. is_fermion(flst(j)) .and. is_massless_vector (flst(i))) then
           ftuple%splitting_type = F_TO_FV
        else
           ftuple%splitting_type = UNDEFINED_SPLITTING
        end if
     end associate
   end subroutine ftuple_determine_splitting_type_fsr
 
 @ %def ftuple_determine_splitting_type_fsr
 @ Determines the splitting type for ISR. There are four different types of splittings
 relevant here: $g \to gg$ tagged [[V_TO_VV]], $g \to qq$ tagged [[V_TO_FF]], $q \to qg$
 tagged [[F_TO_FV]] and $q \to gq$ tagged [[F_TO_VF]]. The latter two need to be considered
 separately for ISR as they differ with respect to which particle enters the hard process.
 A splitting [[F_TO_FV]] may lead to soft divergences while [[F_TO_VF]] does not.\\
 We also want to emphasize that the splitting type naming convention for ISR names the
 splittings considering backwards evolution. So in the splitting [[V_TO_FF]], it is the
 \textit{gluon} that enteres the hard process!\\
 Special treatment here is required if emitter $0$ is assigned. This is the case only when a
 gluon was radiated from any of the IS particles. In this case, both splittings are soft divergent
 so we can equivalently choose $1$ or $2$ as the emitter here even if both have different flavors.
 <<fks regions: ftuple: TBP>>=
   procedure :: determine_splitting_type_isr => ftuple_determine_splitting_type_isr
 <<fks regions: procedures>>=
   subroutine ftuple_determine_splitting_type_isr (ftuple, flv, i, j)
     class(ftuple_t), intent(inout) :: ftuple
     type(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i, j
     integer :: em
     em = i; if (i == 0) em = 1
     associate (flst => flv%flst)
        if (is_vector (flst(em)) .and. is_vector (flst(j))) then
           ftuple%splitting_type = V_TO_VV
        else if (is_massless_vector(flst(em)) .and. is_fermion(flst(j))) then
           ftuple%splitting_type = F_TO_VF
        else if (is_fermion(flst(em)) .and. is_massless_vector(flst(j))) then
           ftuple%splitting_type = F_TO_FV
        else if (is_fermion(flst(em)) .and. is_fermion(flst(j))) then
           ftuple%splitting_type = V_TO_FF
        else
           ftuple%splitting_type = UNDEFINED_SPLITTING
        end if
     end associate
   end subroutine ftuple_determine_splitting_type_isr
 
 @ %def ftuple_determine_splitting_type_isr
 @ Two debug functions to check the consistency of [[ftuples]]
 <<fks regions: ftuple: TBP>>=
   procedure :: has_negative_elements => ftuple_has_negative_elements
   procedure :: has_identical_elements => ftuple_has_identical_elements
 <<fks regions: procedures>>=
   elemental function ftuple_has_negative_elements (ftuple) result (value)
     logical :: value
     class(ftuple_t), intent(in) :: ftuple
     value = any (ftuple%ireg < 0)
   end function ftuple_has_negative_elements
 
   elemental function ftuple_has_identical_elements (ftuple) result (value)
     logical :: value
     class(ftuple_t), intent(in) :: ftuple
     value = ftuple%ireg(1) == ftuple%ireg(2)
   end function ftuple_has_identical_elements
 
 @ %def ftuple_has_negative_elements, ftuple_has_identical_elements
 @ Each singular region can have a different number of
 emitter-radiation pairs. This is coped with using the linked list
 [[ftuple_list]].
 <<fks regions: types>>=
   type :: ftuple_list_t
     integer :: index = 0
     type(ftuple_t) :: ftuple
     type(ftuple_list_t), pointer :: next => null ()
     type(ftuple_list_t), pointer :: prev => null ()
     type(ftuple_list_t), pointer :: equiv => null ()
   contains
    <<fks regions: ftuple list: TBP>>
   end type ftuple_list_t
 
 @ %def ftuple_list_t
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: write => ftuple_list_write
 <<fks regions: procedures>>=
   subroutine ftuple_list_write (list, unit, verbose)
     class(ftuple_list_t), intent(in), target :: list
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     type(ftuple_list_t), pointer :: current
     logical :: verb
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     verb = .false.; if (present (verbose)) verb = verbose
     select type (list)
     type is (ftuple_list_t)
        current => list
        do
           call current%ftuple%write (unit = u, newline = .false.)
           if (verb .and. associated (current%equiv)) write (u, '(A)', advance = "no") "'"
           if (associated (current%next)) then
              current => current%next
           else
              exit
           end if
        end do
        write (u, *) ""
     end select
   end subroutine ftuple_list_write
 
 @ %def ftuple_list_write
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: append => ftuple_list_append
 <<fks regions: procedures>>=
   subroutine ftuple_list_append (list, ftuple)
    class(ftuple_list_t), intent(inout), target :: list
    type(ftuple_t), intent(in) :: ftuple
    type(ftuple_list_t), pointer :: current
 
    select type (list)
    type is (ftuple_list_t)
    if (list%index == 0) then
       nullify (list%next)
       list%index = 1
       list%ftuple = ftuple
    else
       current => list
       do
        if (associated (current%next)) then
           current => current%next
        else
           allocate (current%next)
           nullify (current%next%next)
           nullify (current%next%equiv)
           current%next%prev => current
           current%next%index = current%index + 1
           current%next%ftuple = ftuple
           exit
        end if
      end do
    end if
    end select
   end subroutine ftuple_list_append
 
 @ %def ftuple_list_append
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: get_n_tuples => ftuple_list_get_n_tuples
 <<fks regions: procedures>>=
   impure elemental function ftuple_list_get_n_tuples (list) result(n_tuples)
     integer :: n_tuples
     class(ftuple_list_t), intent(in), target :: list
     type(ftuple_list_t), pointer :: current
     n_tuples = 0
     select type (list)
     type is (ftuple_list_t)
        current => list
        if (current%index > 0) then
           n_tuples = 1
           do
              if (associated (current%next)) then
                 current => current%next
                 n_tuples = n_tuples + 1
              else
                 exit
              end if
           end do
        end if
      end select
   end function ftuple_list_get_n_tuples
 
 @ %def ftuple_list_get_n_tuples
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: get_entry => ftuple_list_get_entry
 <<fks regions: procedures>>=
   function ftuple_list_get_entry (list, index) result (entry)
     type(ftuple_list_t), pointer :: entry
     class(ftuple_list_t), intent(in), target :: list
     integer, intent(in) :: index
     type(ftuple_list_t), pointer :: current
     integer :: i
     entry => null()
     select type (list)
     type is (ftuple_list_t)
        current => list
        if (index == 1) then
           entry => current
        else
           do i = 1, index - 1
              current => current%next
           end do
           entry => current
        end if
     end select
   end function ftuple_list_get_entry
 
 @ %def ftuple_list_get_entry
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: get_ftuple => ftuple_list_get_ftuple
 <<fks regions: procedures>>=
   function ftuple_list_get_ftuple (list, index)  result (ftuple)
     type(ftuple_t) :: ftuple
     class(ftuple_list_t), intent(in), target :: list
     integer, intent(in) :: index
     type(ftuple_list_t), pointer :: entry
     entry => list%get_entry (index)
     ftuple = entry%ftuple
   end function ftuple_list_get_ftuple
 
 @ %def ftuple_list_get_ftuple
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: set_equiv => ftuple_list_set_equiv
 <<fks regions: procedures>>=
   subroutine ftuple_list_set_equiv (list, i1, i2)
     class(ftuple_list_t), intent(in) :: list
     integer, intent(in) :: i1, i2
     type(ftuple_list_t), pointer :: list1, list2 => null ()
     select type (list)
     type is (ftuple_list_t)
        if (list%get_ftuple (i1) > list%get_ftuple (i2)) then
           list1 => list%get_entry (i2)
           list2 => list%get_entry (i1)
        else
           list1 => list%get_entry (i1)
           list2 => list%get_entry (i2)
        end if
        do
           if (associated (list1%equiv)) then
              list1 => list1%equiv
           else
              exit
           end if
        end do
        list1%equiv => list2
     end select
   end subroutine ftuple_list_set_equiv
 
 @ %def ftuple_list_set_equiv
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: check_equiv => ftuple_list_check_equiv
 <<fks regions: procedures>>=
   function ftuple_list_check_equiv(list, i1, i2) result(eq)
     class(ftuple_list_t), intent(in) :: list
     integer, intent(in) :: i1, i2
     logical :: eq
     type(ftuple_list_t), pointer :: current
     eq = .false.
     select type (list)
     type is (ftuple_list_t)
        current => list%get_entry (i1)
        do
           if (associated (current%equiv)) then
              current => current%equiv
              if (current%index == i2) then
                 eq = .true.
                 exit
              end if
           else
              exit
           end if
        end do
     end select
   end function ftuple_list_check_equiv
 
 @ %def ftuple_list_sort
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: to_array => ftuple_list_to_array
 <<fks regions: procedures>>=
   subroutine ftuple_list_to_array (ftuple_list, ftuple_array, equivalences, ordered)
     class(ftuple_list_t), intent(in), target :: ftuple_list
     type(ftuple_t), intent(out), dimension(:), allocatable :: ftuple_array
     logical, intent(out), dimension(:,:), allocatable :: equivalences
     logical, intent(in) :: ordered
     integer :: i_tuple, n
     type(ftuple_list_t), pointer :: current => null ()
     integer :: i1, i2
     type(ftuple_t) :: ftuple_tmp
     logical, dimension(:), allocatable :: eq_tmp
     n = ftuple_list%get_n_tuples ()
     allocate (ftuple_array (n), equivalences (n, n))
     equivalences = .false.
     select type (ftuple_list)
     type is (ftuple_list_t)
        current => ftuple_list
        i_tuple = 1
        do
           ftuple_array(i_tuple) = current%ftuple
           if (associated (current%equiv)) then
              i1 = current%index
              i2 = current%equiv%index
              equivalences (i1, i2) = .true.
           end if
           if (associated (current%next)) then
              current => current%next
              i_tuple = i_tuple + 1
           else
              exit
           end if
        end do
     end select
     if (ordered) call ftuple_sort_array (ftuple_array, equivalences)
   end subroutine ftuple_list_to_array
 
 @ %def ftuple_list_to_array
 @
 <<fks regions: procedures>>=
   subroutine print_equivalence_matrix (ftuple_array, equivalences)
     type(ftuple_t), intent(in), dimension(:) :: ftuple_array
     logical, intent(in), dimension(:,:) :: equivalences
     integer :: i, i1, i2
     print *, 'Equivalence matrix: '
     do i = 1, size (ftuple_array)
        call ftuple_array(i)%get(i1,i2)
        print *, 'i: ', i, '(', i1, i2, '): ', equivalences(i,:)
     end do
   end subroutine print_equivalence_matrix
 
 @ %def print_equivalence_matrix
 @ Class for working with the flavor specification arrays.
 <<fks regions: public>>=
   public :: flv_structure_t
 <<fks regions: types>>=
   type :: flv_structure_t
     integer, dimension(:), allocatable :: flst
     integer, dimension(:), allocatable :: tag
     integer :: nlegs = 0
     integer :: n_in = 0
     logical, dimension(:), allocatable :: massive
     logical, dimension(:), allocatable :: colored
     real(default), dimension(:), allocatable :: charge
     real(default) :: prt_symm_fs = 1._default
+    integer :: eqv_index = 0
   contains
   <<fks regions: flv structure: TBP>>
   end type flv_structure_t
 
 @ %def flv_structure_t
 @
 Returns \texttt{true} if the two particles at position \texttt{i}
 and \texttt{j} in the flavor array can originate from the same
 splitting. For this purpose, the function first checks whether the splitting is
 allowed at all. If this is the case, the emitter is removed from the
 flavor array. If the resulting array is equivalent to the Born flavor
 structure \texttt{flv\_born}, the pair is accepted as a valid
 splitting.
 
 We first check whether the splitting is possible. The array
 [[flv_orig]] contains all particles which share a vertex with the
 particles at position [[i]] and [[j]]. If any of these particles belongs
 to the initial state, a PDG-ID flip is necessary to correctly recognize
 the vertex. If its size is equal to zero, no splitting is possible and
 the subroutine is exited. Otherwise, we loop over all possible underlying
 Born flavor structures and check if any of them equals the actual underlying
 Born flavor structure. For a quark emitting a gluon, [[flv_orig]] contains
 the PDG code of the anti-quark. To be on the safe side, a second array is created,
 which contains both the positively and negatively signed PDG
 codes. Then, the origial tuple $(i,j)$ is removed from the real flavor
 structure and the particles in [[flv_orig2]] are inserted.
 If the resulting Born configuration is equal to the underlying Born
 configuration, up to a permutation of final-state particles, the tuple
 $(i,j)$ is accepted as valid.
 <<fks regions: flv structure: TBP>>=
   procedure :: valid_pair => flv_structure_valid_pair
 <<fks regions: procedures>>=
   function flv_structure_valid_pair &
      (flv, i, j, flv_ref, model) result (valid)
     logical :: valid
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i,j
     type(flv_structure_t), intent(in) :: flv_ref
     type(model_t), intent(in) :: model
     integer :: k, n_orig
     type(flv_structure_t) :: flv_test
     integer, dimension(:), allocatable :: flv_orig
     valid = .false.
     if (all ([i, j] <= flv%n_in)) return
     if (i <= flv%n_in .and. is_fermion(flv%flst(i))) then
        call model%match_vertex (-flv%flst(i), flv%flst(j), flv_orig)
     else if (j <= flv%n_in .and. is_fermion(flv%flst(j))) then
        call model%match_vertex (flv%flst(i), -flv%flst(j), flv_orig)
     else
        call model%match_vertex (flv%flst(i), flv%flst(j), flv_orig)
     end if
     n_orig = size (flv_orig)
     if (n_orig == 0) then
        return
     else
       do k = 1, n_orig
          if (any ([i, j] <= flv%n_in)) then
             flv_test = flv%insert_particle_isr (i, j, flv_orig(k))
          else
             flv_test = flv%insert_particle_fsr (i, j, flv_orig(k))
          end if
          valid = flv_ref .equiv. flv_test
          call flv_test%final ()
          if (valid) return
       end do
     end if
     deallocate (flv_orig)
   end function flv_structure_valid_pair
 
 @ %def flv_structure_valid_pair
 @ This function checks whether two flavor arrays are the same up to a
 permutation of the final-state particles
 <<fks regions: procedures>>=
   function flv_structure_equivalent (flv1, flv2, with_tag) result(equiv)
     logical :: equiv
     type(flv_structure_t), intent(in) :: flv1, flv2
     logical, intent(in) :: with_tag
     type(flavor_permutation_t) :: perm
     integer :: n
     n = size (flv1%flst)
     equiv = .true.
     if (n /= size (flv2%flst)) then
        call msg_fatal &
             ('flv_structure_equivalent: flavor arrays do not have equal lengths')
     else if (flv1%n_in /= flv2%n_in) then
        call msg_fatal &
             ('flv_structure_equivalent: flavor arrays do not have equal n_in')
     else
        call perm%init (flv1, flv2, flv1%n_in, flv1%nlegs, with_tag)
        equiv = perm%test (flv2, flv1, with_tag)
        call perm%final ()
     end if
   end function flv_structure_equivalent
 
 @ %def flv_structure_equivalent
 @
 <<fks regions: procedures>>=
   function flv_structure_equivalent_no_tag (flv1, flv2) result(equiv)
     logical :: equiv
     type(flv_structure_t), intent(in) :: flv1, flv2
     equiv = flv_structure_equivalent (flv1, flv2, .false.)
   end function flv_structure_equivalent_no_tag
 
   function flv_structure_equivalent_with_tag (flv1, flv2) result(equiv)
     logical :: equiv
     type(flv_structure_t), intent(in) :: flv1, flv2
     equiv = flv_structure_equivalent (flv1, flv2, .true.)
   end function flv_structure_equivalent_with_tag
 
 
 @ %def flv_structure_equivalent_no_tag, flv_structure_equivalent_with_tag
 @
 <<fks regions: procedures>>=
   pure subroutine flv_structure_assign_flv (flv_out, flv_in)
     type(flv_structure_t), intent(out) :: flv_out
     type(flv_structure_t), intent(in) :: flv_in
     flv_out%nlegs = flv_in%nlegs
     flv_out%n_in = flv_in%n_in
     flv_out%prt_symm_fs = flv_in%prt_symm_fs
     if (allocated (flv_in%flst)) then
        allocate (flv_out%flst (size (flv_in%flst)))
        flv_out%flst = flv_in%flst
     end if
     if (allocated (flv_in%tag)) then
        allocate (flv_out%tag (size (flv_in%tag)))
        flv_out%tag = flv_in%tag
     end if
     if (allocated (flv_in%massive)) then
        allocate (flv_out%massive (size (flv_in%massive)))
        flv_out%massive = flv_in%massive
     end if
     if (allocated (flv_in%colored)) then
        allocate (flv_out%colored (size (flv_in%colored)))
        flv_out%colored = flv_in%colored
     end if
   end subroutine flv_structure_assign_flv
 
 @ %def flv_structure_assign_flv
 @
 <<fks regions: procedures>>=
   pure subroutine flv_structure_assign_integer (flv_out, iarray)
     type(flv_structure_t), intent(out) :: flv_out
     integer, intent(in), dimension(:) :: iarray
     integer :: i
     flv_out%nlegs = size (iarray)
     allocate (flv_out%flst (flv_out%nlegs))
     allocate (flv_out%tag (flv_out%nlegs))
     flv_out%flst = iarray
     flv_out%tag = [(i, i = 1, flv_out%nlegs)]
   end subroutine flv_structure_assign_integer
 
 @ %def flv_structure_assign_integer
 @ Returs a new flavor array with the particle at position
 \texttt{index} removed.
 <<fks regions: flv structure: TBP>>=
   procedure :: remove_particle => flv_structure_remove_particle
 <<fks regions: procedures>>=
   function flv_structure_remove_particle (flv, index) result(flv_new)
     type(flv_structure_t) :: flv_new
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: index
     integer :: n1, n2
     integer :: i, removed_tag
     n1 = size (flv%flst); n2 = n1 - 1
     allocate (flv_new%flst (n2), flv_new%tag (n2))
     flv_new%nlegs = n2
     flv_new%n_in = flv%n_in
     removed_tag = flv%tag(index)
     if (index == 1) then
        flv_new%flst(1 : n2) = flv%flst(2 : n1)
        flv_new%tag(1 : n2) = flv%tag(2 : n1)
     else if (index == n1) then
        flv_new%flst(1 : n2) = flv%flst(1 : n2)
        flv_new%tag(1 : n2) = flv%tag(1 : n2)
     else
        flv_new%flst(1 : index - 1) = flv%flst(1 : index - 1)
        flv_new%flst(index : n2) = flv%flst(index + 1 : n1)
        flv_new%tag(1 : index - 1) = flv%tag(1 : index - 1)
        flv_new%tag(index : n2) = flv%tag(index + 1 : n1)
     end if
     do i = 1, n2
        if (flv_new%tag(i) > removed_tag) &
             flv_new%tag(i) = flv_new%tag(i) - 1
     end do
     call flv_new%compute_prt_symm_fs (flv_new%n_in)
   end function flv_structure_remove_particle
 
 @ %def flv_structure_remove_particle
 @ Removes the particles at position i1 and i2 and inserts a new
 particle of matching flavor at position i1.
 <<fks regions: flv structure: TBP>>=
   procedure :: insert_particle_fsr => flv_structure_insert_particle_fsr
 <<fks regions: procedures>>=
   function flv_structure_insert_particle_fsr (flv, i1, i2, flv_add) result (flv_new)
     type(flv_structure_t) :: flv_new
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i1, i2, flv_add
     if (flv%flst(i1) + flv_add == 0 .or. flv%flst(i2) + flv_add == 0) then
        flv_new = flv%insert_particle (i1, i2, -flv_add)
     else
        flv_new = flv%insert_particle (i1, i2, flv_add)
     end if
   end function flv_structure_insert_particle_fsr
 
 @ %def flv_structure_insert_particle_fsr
 @ Same as [[insert_particle_fsr]] but for ISR, the two particles are not exchangable.
 <<fks regions: flv structure: TBP>>=
   procedure :: insert_particle_isr => flv_structure_insert_particle_isr
 <<fks regions: procedures>>=
   function flv_structure_insert_particle_isr (flv, i_in, i_out, flv_add) result (flv_new)
     type(flv_structure_t) :: flv_new
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i_in, i_out, flv_add
     if (flv%flst(i_in) + flv_add == 0) then
        flv_new = flv%insert_particle (i_in, i_out, -flv_add)
     else
        flv_new = flv%insert_particle (i_in, i_out, flv_add)
     end if
   end function flv_structure_insert_particle_isr
 
 @ %def flv_structure_insert_particle_isr
 @ Removes the particles at position i1 and i2 and inserts a new
 particle at position i1.
 <<fks regions: flv structure: TBP>>=
   procedure :: insert_particle => flv_structure_insert_particle
 <<fks regions: procedures>>=
   function flv_structure_insert_particle (flv, i1, i2, particle) result (flv_new)
     type(flv_structure_t) :: flv_new
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i1, i2, particle
     type(flv_structure_t) :: flv_tmp
     integer :: n1, n2
     integer :: new_tag
     n1 = size (flv%flst); n2 = n1 - 1
     allocate (flv_new%flst (n2), flv_new%tag (n2))
     flv_new%nlegs = n2
     flv_new%n_in = flv%n_in
     new_tag = maxval(flv%tag) + 1
     if (i1 < i2) then
        flv_tmp = flv%remove_particle (i1)
        flv_tmp = flv_tmp%remove_particle (i2 - 1)
     else if(i2 < i1) then
        flv_tmp = flv%remove_particle(i2)
        flv_tmp = flv_tmp%remove_particle(i1 - 1)
     else
        call msg_fatal ("flv_structure_insert_particle: Indices are identical!")
     end if
     if (i1 == 1) then
        flv_new%flst(1) = particle
        flv_new%flst(2 : n2) = flv_tmp%flst(1 : n2 - 1)
        flv_new%tag(1) = new_tag
        flv_new%tag(2 : n2) = flv_tmp%tag(1 : n2 - 1)
     else if (i1 == n1 .or. i1 == n2) then
        flv_new%flst(1 : n2 - 1) = flv_tmp%flst(1 : n2 - 1)
        flv_new%flst(n2) = particle
        flv_new%tag(1 : n2 - 1) = flv_tmp%tag(1 : n2 - 1)
        flv_new%tag(n2) = new_tag
     else
        flv_new%flst(1 : i1 - 1) = flv_tmp%flst(1 : i1 - 1)
        flv_new%flst(i1) = particle
        flv_new%flst(i1 + 1 : n2) = flv_tmp%flst(i1 : n2 - 1)
        flv_new%tag(1 : i1 - 1) = flv_tmp%tag(1 : i1 - 1)
        flv_new%tag(i1) = new_tag
        flv_new%tag(i1 + 1 : n2) = flv_tmp%tag(i1 : n2 - 1)
     end if
     call flv_new%compute_prt_symm_fs (flv_new%n_in)
   end function flv_structure_insert_particle
 
 @ %def flv_structure_insert_particle
 @ Counts the number of occurances of a particle in a
 flavor array
 <<fks regions: flv structure: TBP>>=
   procedure :: count_particle => flv_structure_count_particle
 <<fks regions: procedures>>=
   function flv_structure_count_particle (flv, part) result (n)
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: part
     integer :: n
     n = count (flv%flst == part)
   end function flv_structure_count_particle
 
 @ %def flv_structure_count_particle
 @ Initializer for flavor structures
 <<fks regions: flv structure: TBP>>=
   procedure :: init => flv_structure_init
 <<fks regions: procedures>>=
   subroutine flv_structure_init (flv, aval, n_in, tags)
     class(flv_structure_t), intent(inout) :: flv
     integer, intent(in), dimension(:) :: aval
     integer, intent(in) :: n_in
     integer, intent(in), dimension(:), optional :: tags
     integer :: i, n
     integer, dimension(:), allocatable :: aval_unique
     integer, dimension(:), allocatable :: mult
     n = size (aval)
     allocate (flv%flst (n), flv%tag (n))
     flv%flst = aval
     if (present (tags)) then
        flv%tag = tags
     else
        do i = 1, n
           flv%tag(i) = i
        end do
     end if
     flv%nlegs = n
     flv%n_in = n_in
     call flv%compute_prt_symm_fs (flv%n_in)
   end subroutine flv_structure_init
 
 @ %def flv_structure_init
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: compute_prt_symm_fs => flv_structure_compute_prt_symm_fs
 <<fks regions: procedures>>=
   subroutine flv_structure_compute_prt_symm_fs (flv, n_in)
     class(flv_structure_t), intent(inout) :: flv
     integer, intent(in) :: n_in
     integer, dimension(:), allocatable :: flst_unique
     integer, dimension(:), allocatable :: mult
     integer :: i
     flst_unique = remove_duplicates_from_int_array (flv%flst(n_in + 1 :))
     allocate (mult(size (flst_unique)))
     do i = 1, size (flst_unique)
        mult(i) = count (flv%flst(n_in + 1 :) == flst_unique(i))
     end do
     flv%prt_symm_fs = one / product (gamma (real (mult + 1, default)))
   end subroutine flv_structure_compute_prt_symm_fs
 
 @ %def flv_structure_compute_prt_symm_fs
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: write => flv_structure_write
 <<fks regions: procedures>>=
   subroutine flv_structure_write (flv, unit)
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     write (u, '(A)') char (flv%to_string ())
   end subroutine flv_structure_write
 
 @ %def flv_structure_write
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: to_string => flv_structure_to_string
 <<fks regions: procedures>>=
   function flv_structure_to_string (flv) result (flv_string)
     type(string_t) :: flv_string
     class(flv_structure_t), intent(in) :: flv
     integer :: i, n
     if (allocated (flv%flst)) then
        flv_string = var_str ("[")
        n = size (flv%flst)
        do i = 1, n - 1
           flv_string = flv_string // str (flv%flst(i)) // var_str(",")
        end do
        flv_string = flv_string // str (flv%flst(n)) // var_str("]")
     else
        flv_string = var_str ("[not allocated]")
     end if
   end function flv_structure_to_string
 
 @ %def flv_structure_to_string
 @ Creates the underlying Born flavor structure for a given real flavor
 structure if the particle at position \texttt{emitter} is removed
 <<fks regions: flv structure: TBP>>=
   procedure :: create_uborn => flv_structure_create_uborn
 <<fks regions: procedures>>=
   function flv_structure_create_uborn (flv, emitter, nlo_correction_type) result(flv_uborn)
     type(flv_structure_t) :: flv_uborn
     class(flv_structure_t), intent(in) :: flv
     type(string_t), intent(in) :: nlo_correction_type
     integer, intent(in) :: emitter
     integer n_legs
     integer :: f1, f2
     integer :: gauge_boson
 
     n_legs = size(flv%flst)
     allocate (flv_uborn%flst (n_legs - 1), flv_uborn%tag (n_legs - 1))
     gauge_boson = determine_gauge_boson_to_be_inserted ()
 
     if (emitter > flv%n_in) then
        f1 = flv%flst(n_legs); f2 = flv%flst(n_legs - 1)
        if (is_massless_vector (f1)) then
           !!! Emitted particle is a gluon or photon => just remove it
           flv_uborn = flv%remove_particle(n_legs)
        else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 + f2 == 0) then
           !!! Emission type is a gauge boson splitting into two fermions
           flv_uborn = flv%insert_particle(n_legs - 1, n_legs, gauge_boson)
        else
           call msg_error ("Create underlying Born: Unsupported splitting type.")
           call msg_error (char (str (flv%flst)))
           call msg_fatal ("FKS - FAIL")
        end if
     else if (emitter > 0) then
        f1 = flv%flst(n_legs); f2 = flv%flst(emitter)
        if (is_massless_vector (f1)) then
           flv_uborn = flv%remove_particle(n_legs)
        else if (is_fermion (f1) .and. is_massless_vector (f2)) then
           flv_uborn = flv%insert_particle (emitter, n_legs, -f1)
        else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 == f2) then
           flv_uborn = flv%insert_particle(emitter, n_legs, gauge_boson)
        end if
     else
        flv_uborn = flv%remove_particle (n_legs)
     end if
 
   contains
     integer function determine_gauge_boson_to_be_inserted ()
       select case (char (nlo_correction_type))
       case ("QCD")
          determine_gauge_boson_to_be_inserted = GLUON
       case ("EW")
          determine_gauge_boson_to_be_inserted = PHOTON
       case ("Full")
          call msg_fatal ("NLO correction type 'Full' not yet implemented!")
       case default
          call msg_fatal ("Invalid NLO correction type! Valid inputs are: QCD, EW and Full (default: QCD)")
       end select
     end function determine_gauge_boson_to_be_inserted
 
   end function flv_structure_create_uborn
 
 @ %def flv_structure_create_uborn
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: init_mass_color_and_charge => flv_structure_init_mass_color_and_charge
 <<fks regions: procedures>>=
   subroutine flv_structure_init_mass_color_and_charge (flv, model)
     class(flv_structure_t), intent(inout) :: flv
     type(model_t), intent(in) :: model
     integer :: i
     type(flavor_t) :: flavor
     allocate (flv%massive (flv%nlegs), flv%colored(flv%nlegs), flv%charge(flv%nlegs))
     do i = 1, flv%nlegs
        call flavor%init (flv%flst(i), model)
        flv%massive(i) = flavor%get_mass () > 0
        flv%colored(i) = &
             is_quark (flv%flst(i)) .or. is_gluon (flv%flst(i))
        if (flavor%is_antiparticle ()) then
           flv%charge(i) = -flavor%get_charge ()
        else
           flv%charge(i) = flavor%get_charge ()
        end if
     end do
   end subroutine flv_structure_init_mass_color_and_charge
 
 @ %def flv_structure_init_mass_color_and_charge
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: get_last_two => flv_structure_get_last_two
 <<fks regions: procedures>>=
   function flv_structure_get_last_two (flv, n) result (flst_last)
     integer, dimension(2) :: flst_last
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: n
     flst_last = [flv%flst(n - 1), flv%flst(n)]
   end function flv_structure_get_last_two
 
 @ %def flv_structure_get_last_two
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: final => flv_structure_final
 <<fks regions: procedures>>=
   subroutine flv_structure_final (flv)
     class(flv_structure_t), intent(inout) :: flv
     if (allocated (flv%flst)) deallocate (flv%flst)
     if (allocated (flv%tag)) deallocate (flv%tag)
     if (allocated (flv%massive)) deallocate (flv%massive)
     if (allocated (flv%colored)) deallocate (flv%colored)
     if (allocated (flv%charge)) deallocate (flv%charge)
   end subroutine flv_structure_final
 
 @ %def flv_structure_final
 @
 <<fks regions: public>>=
   public :: flavor_permutation_t
 <<fks regions: types>>=
   type :: flavor_permutation_t
     integer, dimension(:,:), allocatable :: perms
   contains
   <<fks regions: flavor permutation: TBP>>
   end type flavor_permutation_t
 
 @ %def flavor_permutation_t
 @
 <<fks regions: flavor permutation: TBP>>=
   procedure :: init => flavor_permutation_init
 <<fks regions: procedures>>=
   subroutine flavor_permutation_init (perm, flv_in, flv_ref, n_first, n_last, with_tag)
     class(flavor_permutation_t), intent(out) :: perm
     type(flv_structure_t), intent(in) :: flv_in, flv_ref
     integer, intent(in) :: n_first, n_last
     logical, intent(in) :: with_tag
     integer :: flv1, flv2, tmp
     integer :: tag1, tag2
     integer :: i, j, j_min, i_perm
     integer, dimension(:,:), allocatable :: perm_list_tmp
     type(flv_structure_t) :: flv_copy
     logical :: condition
     logical, dimension(:), allocatable :: already_correct
     flv_copy = flv_in
     allocate (perm_list_tmp (factorial (n_last - n_first - 1), 2))
     allocate (already_correct (flv_in%nlegs))
     already_correct = flv_in%flst == flv_ref%flst
     if (with_tag) &
          already_correct = already_correct .and. (flv_in%tag == flv_ref%tag)
     j_min = n_first + 1
     i_perm = 0
     do i = n_first + 1, n_last
        flv1 = flv_ref%flst(i)
        tag1 = flv_ref%tag(i)
        do j = j_min, n_last
           if (already_correct(i) .or. already_correct(j)) cycle
           flv2 = flv_copy%flst(j)
           tag2 = flv_copy%tag(j)
           condition = (flv1 == flv2) .and. i /= j
           if (with_tag) condition = condition .and. (tag1 == tag2)
           if (condition) then
              i_perm = i_perm + 1
              tmp = flv_copy%flst(i)
              flv_copy%flst(i) = flv2
              flv_copy%flst(j) = tmp
              tmp = flv_copy%tag(i)
              flv_copy%tag(i) = tag2
              flv_copy%tag(j) = tmp
              perm_list_tmp (i_perm, 1) = i
              perm_list_tmp (i_perm, 2) = j
              exit
           end if
        end do
        j_min = j_min + 1
     end do
     allocate (perm%perms (i_perm, 2))
     perm%perms = perm_list_tmp (1 : i_perm, :)
     deallocate (perm_list_tmp)
     call flv_copy%final ()
   end subroutine flavor_permutation_init
 
 @ %def flavor_permutation_init
 @
 <<fks regions: flavor permutation: TBP>>=
   procedure :: write => flavor_permutation_write
 <<fks regions: procedures>>=
   subroutine flavor_permutation_write (perm, unit)
     class(flavor_permutation_t), intent(in) :: perm
     integer, intent(in), optional :: unit
     integer :: i, n, u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(A)") "Flavor permutation list: "
     n = size (perm%perms, dim = 1)
     if (n > 0) then
        do i = 1, n
           write (u, "(A1,I1,1X,I1,A1)", advance = "no") "[", perm%perms(i,1), perm%perms(i,2), "]"
           if (i < n) write (u, "(A4)", advance = "no") " // "
        end do
        write (u, "(A)") ""
     else
        write (u, "(A)") "[Empty]"
     end if
   end subroutine flavor_permutation_write
 
 @ %def flavor_permutation_write
 @
 <<fks regions: flavor permutation: TBP>>=
   procedure :: reset => flavor_permutation_final
   procedure :: final => flavor_permutation_final
 <<fks regions: procedures>>=
   subroutine flavor_permutation_final (perm)
     class(flavor_permutation_t), intent(inout) :: perm
     if (allocated (perm%perms)) deallocate (perm%perms)
   end subroutine flavor_permutation_final
 
 @ %def flavor_permutation_final
 @
 <<fks regions: flavor permutation: TBP>>=
   generic :: apply => apply_permutation, &
          apply_flavor, apply_integer, apply_ftuple
   procedure :: apply_permutation => flavor_permutation_apply_permutation
   procedure :: apply_flavor => flavor_permutation_apply_flavor
   procedure :: apply_integer => flavor_permutation_apply_integer
   procedure :: apply_ftuple => flavor_permutation_apply_ftuple
 <<fks regions: procedures>>=
   elemental function flavor_permutation_apply_permutation (perm_1, perm_2) &
          result (perm_out)
     type(flavor_permutation_t) :: perm_out
     class(flavor_permutation_t), intent(in) :: perm_1
     type(flavor_permutation_t), intent(in) :: perm_2
     integer :: n1, n2
     n1 = size (perm_1%perms, dim = 1)
     n2 = size (perm_2%perms, dim = 1)
     allocate (perm_out%perms (n1 + n2, 2))
     perm_out%perms (1 : n1, :) = perm_1%perms
     perm_out%perms (n1 + 1: n1 + n2, :) = perm_2%perms
   end function flavor_permutation_apply_permutation
 
 @ %def flavor_permutation_apply_permutation
 @
 <<fks regions: procedures>>=
   elemental function flavor_permutation_apply_flavor (perm, flv_in, invert) &
          result (flv_out)
     type(flv_structure_t) :: flv_out
     class(flavor_permutation_t), intent(in) :: perm
     type(flv_structure_t), intent(in) :: flv_in
     logical, intent(in), optional :: invert
     integer :: i, i1, i2
     integer :: p1, p2, incr
     integer :: flv_tmp, tag_tmp
     logical :: inv
     inv = .false.; if (present(invert)) inv = invert
     flv_out = flv_in
     if (inv) then
        p1 = 1
        p2 = size (perm%perms, dim = 1)
        incr = 1
     else
        p1 = size (perm%perms, dim = 1)
        p2 = 1
        incr = -1
     end if
     do i = p1, p2, incr
        i1 = perm%perms(i,1)
        i2 = perm%perms(i,2)
        flv_tmp = flv_out%flst(i1)
        tag_tmp = flv_out%tag(i1)
        flv_out%flst(i1) = flv_out%flst(i2)
        flv_out%flst(i2) = flv_tmp
        flv_out%tag(i1) = flv_out%tag(i2)
        flv_out%tag(i2) = tag_tmp
     end do
   end function flavor_permutation_apply_flavor
 
 @ %def flavor_permutation_apply_flavor
 @
 <<fks regions: procedures>>=
   elemental function flavor_permutation_apply_integer (perm, i_in) result (i_out)
     integer :: i_out
     class(flavor_permutation_t), intent(in) :: perm
     integer, intent(in) :: i_in
     integer :: i, i1, i2
     i_out = i_in
     do i = size (perm%perms(:,1)), 1, -1
        i1 = perm%perms(i,1)
        i2 = perm%perms(i,2)
        if (i_out == i1) then
           i_out = i2
        else if (i_out == i2) then
           i_out = i1
        end if
     end do
   end function flavor_permutation_apply_integer
 
 @ %def flavor_permutation_apply_integer
 @
 <<fks regions: procedures>>=
   elemental function flavor_permutation_apply_ftuple (perm, f_in) result (f_out)
     type(ftuple_t) :: f_out
     class(flavor_permutation_t), intent(in) :: perm
     type(ftuple_t), intent(in) :: f_in
     integer :: i, i1, i2
     f_out = f_in
     do i = size (perm%perms, dim = 1), 1, -1
        i1 = perm%perms(i,1)
        i2 = perm%perms(i,2)
        if (f_out%ireg(1) == i1) then
           f_out%ireg(1) = i2
        else if (f_out%ireg(1) == i2) then
           f_out%ireg(1) = i1
        end if
        if (f_out%ireg(2) == i1) then
           f_out%ireg(2) = i2
        else if (f_out%ireg(2) == i2) then
           f_out%ireg(2) = i1
        end if
     end do
     if (f_out%ireg(1) > f_out%ireg(2)) f_out%ireg = f_out%ireg([2,1])
   end function flavor_permutation_apply_ftuple
 
 @ %def flavor_permutation_apply_ftuple
 @
 <<fks regions: flavor permutation: TBP>>=
   procedure :: test => flavor_permutation_test
 <<fks regions: procedures>>=
   function flavor_permutation_test (perm, flv1, flv2, with_tag) result (valid)
     logical :: valid
     class(flavor_permutation_t), intent(in) :: perm
     type(flv_structure_t), intent(in) :: flv1, flv2
     logical, intent(in) :: with_tag
     type(flv_structure_t) :: flv_test
     flv_test = perm%apply (flv2, invert = .true.)
     valid = all (flv_test%flst == flv1%flst)
     if (with_tag) valid = valid .and. all (flv_test%tag == flv1%tag)
     call flv_test%final ()
   end function flavor_permutation_test
 
 @ %def flavor_permutation_test
 @ A singular region is a partition of phase space which is associated with
 an individual emitter and, if relevant, resonance. It is associated with
 an $\alpha_r$- and resonance-index, with a real flavor structure and
 its underlying Born flavor structure. To compute the FKS weights, it is
 relevant to know all the other particle indices which can result in a
 divergenent phase space configuration, which are collected in the
 [[ftuples]]-array.
 
 Some singular regions might behave physically identical. E.g. a real
 flavor structure associated with three-jet production is $[11,-11,2,-2,21,21]$.
 Here, there are two possible [[ftuples]] which contribute to the same
 $u \rightarrow u g$ splitting, namely $(3,5)$ and $(3,6)$. The resulting
 singular regions will be identical. To avoid this, one singular region
 is associated with the multiplicity factor [[mult]]. When computing the
 subtraction terms for each singular region, the result is then simply
 multiplied by this factor.\\
 The [[double_fsr]]-flag indicates whether the singular region should
 also be supplied by a symmetry factor, explained below.
 <<fks regions: public>>=
   public :: singular_region_t
 <<fks regions: types>>=
   type :: singular_region_t
     integer :: alr
     integer :: i_res
     type(flv_structure_t) :: flst_real
     type(flv_structure_t) :: flst_uborn
     integer :: mult
     integer :: emitter
     integer :: nregions
     integer :: real_index
     type(ftuple_t), dimension(:), allocatable :: ftuples
     integer :: uborn_index
     logical :: double_fsr = .false.
     logical :: soft_divergence = .false.
     logical :: coll_divergence = .false.
     type(string_t) :: nlo_correction_type
     integer, dimension(:), allocatable :: i_reg_to_i_con
     logical :: pseudo_isr = .false.
     logical :: sc_required = .false.
+    integer :: eqv_index = 0
   contains
   <<fks regions: singular region: TBP>>
   end type singular_region_t
 
 @ %def singular_region_t
 @
 <<fks regions: singular region: TBP>>=
   procedure :: init => singular_region_init
 <<fks regions: procedures>>=
   subroutine singular_region_init (sregion, alr, mult, i_res, &
          flst_real, flst_uborn, flv_born, emitter, ftuples, equivalences, &
          nlo_correction_type)
     class(singular_region_t), intent(out) :: sregion
     integer, intent(in) :: alr, mult, i_res
     type(flv_structure_t), intent(in) :: flst_real
     type(flv_structure_t), intent(in) :: flst_uborn
     type(flv_structure_t), dimension(:), intent(in) :: flv_born
     integer, intent(in) :: emitter
     type(ftuple_t), intent(inout), dimension(:) :: ftuples
     logical, intent(inout), dimension(:,:) :: equivalences
     type(string_t), intent(in) :: nlo_correction_type
     integer :: i
     call debug_input_values ()
     sregion%alr = alr
     sregion%mult = mult
     sregion%i_res = i_res
     sregion%flst_real = flst_real
     sregion%flst_uborn = flst_uborn
     sregion%emitter = emitter
     sregion%nlo_correction_type = nlo_correction_type
     sregion%nregions = size (ftuples)
     allocate (sregion%ftuples (sregion%nregions))
     sregion%ftuples = ftuples
     do i = 1, size(flv_born)
        if (flv_born (i) .equiv. sregion%flst_uborn) then
           sregion%uborn_index = i
           exit
        end if
     end do
     sregion%sc_required = any (sregion%flst_uborn%flst == GLUON) .or. &
             any (sregion%flst_uborn%flst == PHOTON)
   contains
     subroutine debug_input_values()
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "singular_region_init")
       if (debug2_active (D_SUBTRACTION)) then
          print *, 'alr =    ', alr
          print *, 'mult =    ', mult
          print *, 'i_res =    ', i_res
          call flst_real%write ()
          call flst_uborn%write ()
          print *, 'emitter =    ', emitter
          call print_equivalence_matrix (ftuples, equivalences)
       end if
     end subroutine debug_input_values
   end subroutine singular_region_init
 
 @ %def singular_region_init
 <<fks regions: singular region: TBP>>=
   procedure :: write => singular_region_write
 <<fks regions: procedures>>=
   subroutine singular_region_write (sregion, unit, maxnregions)
     class(singular_region_t), intent(in) :: sregion
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: maxnregions
     character(len=7), parameter :: flst_format = "(I3,A1)"
     character(len=7), parameter :: ireg_space_format = "(7X,A1)"
     integer :: nreal, nborn, i, u, mr
     integer :: nleft, nright, nreg, nreg_diff
     u = given_output_unit (unit); if (u < 0) return
     mr = sregion%nregions; if (present (maxnregions))  mr = maxnregions
     nreal = size (sregion%flst_real%flst)
     nborn = size (sregion%flst_uborn%flst)
     call write_vline (u)
     write (u, '(A1)', advance = 'no') '['
     do i = 1, nreal - 1
        write (u, flst_format, advance = 'no') sregion%flst_real%flst(i), ','
     end do
     write (u, flst_format, advance = 'no') sregion%flst_real%flst(nreal), ']'
     call write_vline (u)
     write (u, '(I6)', advance = 'no') sregion%real_index
     call write_vline (u)
     write (u, '(I3)', advance = 'no') sregion%emitter
     call write_vline (u)
     write (u, '(I3)', advance = 'no') sregion%mult
     call write_vline (u)
     write (u, '(I4)', advance = 'no') sregion%nregions
     call write_vline (u)
     if (sregion%i_res > 0) then
        write (u, '(I3)', advance = 'no') sregion%i_res
        call write_vline (u)
     end if
     nreg = sregion%nregions
     if (nreg == mr) then
        nleft = 0
        nright = 0
     else
        nreg_diff = mr - nreg
        nleft = nreg_diff / 2
        if (mod(nreg_diff , 2) == 0) then
           nright = nleft
        else
           nright = nleft + 1
        end if
     end if
     if (nleft > 0) then
        do i = 1, nleft
           write(u, ireg_space_format, advance='no') ' '
        end do
     end if
     write (u, '(A)', advance = 'no') char (ftuple_string (sregion%ftuples, .false.))
     call write_vline (u)
     write (u,'(A1)',advance = 'no') '['
     do i = 1, nborn - 1
        write(u, flst_format, advance = 'no') sregion%flst_uborn%flst(i), ','
     end do
     write (u, flst_format, advance = 'no') sregion%flst_uborn%flst(nborn), ']'
     call write_vline (u)
     write (u, '(I7)', advance = 'no') sregion%uborn_index
     write (u, '(A)')
   end subroutine singular_region_write
 
 @ %def singular_region_write
 @
 <<fks regions: singular region: TBP>>=
   procedure :: write_latex => singular_region_write_latex
 <<fks regions: procedures>>=
   subroutine singular_region_write_latex (region, unit)
     class(singular_region_t), intent(in) :: region
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(I2,A3,A,A3,I2,A3,I1,A3,I1,A3,A,A3,I2,A3,A,A3)") &
            region%alr, " & ", char (region%flst_real%to_string ()), &
            " & ", region%real_index, " & ", region%emitter, " & ", &
            region%mult, " & ", char (ftuple_string (region%ftuples, .true.)), &
            " & ", region%uborn_index, " & ",  char (region%flst_uborn%to_string ()), &
            " \\"
   end subroutine singular_region_write_latex
 
 @ %def singular_region_write_latex
 @ In case of a $g \rightarrow gg$ splitting, the factor
 \begin{equation*}
  \frac{2E_{\rm{em}}}{E_{\rm{em}} + E_{\rm{rad}}}
 \end{equation*}
 is multiplied to the real matrix element. This way, the symmetry of the splitting is used
 and only one singular region has to be taken into account. However, the factor ensures that
 there is only a soft singularity if the radiated parton becomes soft.
 <<fks regions: singular region: TBP>>=
   procedure :: set_splitting_info => singular_region_set_splitting_info
 <<fks regions: procedures>>=
   subroutine singular_region_set_splitting_info (region, n_in)
     class(singular_region_t), intent(inout) :: region
     integer, intent(in) :: n_in
     integer :: i1, i2
     integer :: reg
     region%double_fsr = .false.
     region%soft_divergence = .false.
     associate (ftuple => region%ftuples)
        do reg = 1, region%nregions
           call ftuple(reg)%get (i1, i2)
           if (i1 /= region%emitter .or. i2 /= region%flst_real%nlegs) then
              cycle
           else
              if (ftuple(reg)%splitting_type == V_TO_VV .or.  &
                  ftuple(reg)%splitting_type == F_TO_FV ) then
                 region%soft_divergence = .true.
              end if
 
              if (i1 == 0) then
                 region%coll_divergence = .not. all (region%flst_real%massive(1:n_in))
              else
                 region%coll_divergence = .not. region%flst_real%massive(i1)
              end if
 
              if (ftuple(reg)%splitting_type == V_TO_VV) then
                 if (all (ftuple(reg)%ireg > n_in))  &
                      region%double_fsr = all (is_gluon (region%flst_real%flst(ftuple(reg)%ireg)))
                 exit
              else if (ftuple(reg)%splitting_type == UNDEFINED_SPLITTING) then
                 call msg_fatal ("All splittings should be defined!")
              end if
           end if
        end do
        if (.not. region%soft_divergence .and. .not. region%coll_divergence) &
             call msg_fatal ("Singular region defined without divergence!")
      end associate
   end subroutine singular_region_set_splitting_info
 
 @ %def singular_region_set_splitting_info
 @
 <<fks regions: singular region: TBP>>=
   procedure :: double_fsr_factor => singular_region_double_fsr_factor
 <<fks regions: procedures>>=
   function singular_region_double_fsr_factor (region, p) result (val)
     class(singular_region_t), intent(in) :: region
     type(vector4_t), intent(in), dimension(:) :: p
     real(default) :: val
     real(default) :: E_rad, E_em
     if (region%double_fsr) then
        E_em = energy (p(region%emitter))
        E_rad = energy (p(region%flst_real%nlegs))
        val = two * E_em / (E_em + E_rad)
     else
        val = one
     end if
   end function singular_region_double_fsr_factor
 
 @ %def singular_region_double_fsr_factor
 @
 <<fks regions: singular region: TBP>>=
   procedure :: has_soft_divergence => singular_region_has_soft_divergence
 <<fks regions: procedures>>=
   function singular_region_has_soft_divergence (region) result (div)
      logical :: div
      class(singular_region_t), intent(in) :: region
      div = region%soft_divergence
   end function singular_region_has_soft_divergence
 
 @ %def singular_region_has_soft_divergence
 @
 <<fks regions: singular region: TBP>>=
   procedure :: has_collinear_divergence => &
          singular_region_has_collinear_divergence
 <<fks regions: procedures>>=
   function singular_region_has_collinear_divergence (region) result (div)
     logical :: div
     class(singular_region_t), intent(in) :: region
     div = region%coll_divergence
   end function singular_region_has_collinear_divergence
 
 @ %def singular_region_has_collinear_divergence
 @
 <<fks regions: singular region: TBP>>=
   procedure :: has_identical_ftuples => singular_region_has_identical_ftuples
 <<fks regions: procedures>>=
   elemental function singular_region_has_identical_ftuples (sregion) result (value)
     logical :: value
     class(singular_region_t), intent(in) :: sregion
     integer :: alr
     value = .false.
     do alr = 1, sregion%nregions
        value = value .or. (count (sregion%ftuples(alr) == sregion%ftuples) > 1)
     end do
   end function singular_region_has_identical_ftuples
 
 @ %def singular_region_has_identical_ftuples
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure singular_region_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine singular_region_assign (reg_out, reg_in)
     type(singular_region_t), intent(out) :: reg_out
     type(singular_region_t), intent(in) :: reg_in
     reg_out%alr = reg_in%alr
     reg_out%i_res = reg_in%i_res
     reg_out%flst_real = reg_in%flst_real
     reg_out%flst_uborn = reg_in%flst_uborn
     reg_out%mult = reg_in%mult
     reg_out%emitter = reg_in%emitter
     reg_out%nregions = reg_in%nregions
     reg_out%real_index = reg_in%real_index
     reg_out%uborn_index = reg_in%uborn_index
     reg_out%double_fsr = reg_in%double_fsr
     reg_out%soft_divergence = reg_in%soft_divergence
     reg_out%coll_divergence = reg_in%coll_divergence
     reg_out%nlo_correction_type = reg_in%nlo_correction_type
     if (allocated (reg_in%ftuples)) then
        allocate (reg_out%ftuples (size (reg_in%ftuples)))
        reg_out%ftuples = reg_in%ftuples
     else
        call msg_bug ("singular_region_assign: Trying to copy a singular region without allocated ftuples!")
     end if
   end subroutine singular_region_assign
-
 @ %def singular_region_assign
+@ Two singular regions match if they would produce the same amplitude.
+For this we have to check that their real and underlying Born flavor
+structures are equivalent, as determined by the [[prc_core]]. However,
+since there are more aspects of a singular region that make it unique,
+we have to check other attributes as well.
+<<fks regions: interfaces>>=
+  interface operator(.match.)
+     module procedure singular_region_match
+  end interface
+
+<<fks regions: procedures>>=
+  function singular_region_match (reg1, reg2) result (match)
+    type(singular_region_t), intent(in) :: reg1, reg2
+    logical :: match
+    match = all ([reg1%flst_real%eqv_index, reg2%flst_real%eqv_index] > 0)
+    match = match .and. (reg1%flst_real%eqv_index == reg2%flst_real%eqv_index)
+    match = match .and. (reg1%flst_uborn%eqv_index == reg2%flst_uborn%eqv_index)
+    match = match .and. (reg1%mult == reg2%mult)
+    match = match .and. (reg1%emitter == reg2%emitter)
+    match = match .and. (reg1%nregions == reg2%nregions)
+    match = match .and. (reg1%double_fsr .eqv. reg2%double_fsr)
+    match = match .and. (reg1%soft_divergence .eqv. reg2%soft_divergence)
+    match = match .and. (reg1%coll_divergence .eqv. reg2%coll_divergence)
+    match = match .and. (char (reg1%nlo_correction_type) == char (reg2%nlo_correction_type))
+    if (match) match = match .and. (all (reg1%ftuples == reg2%ftuples))
+  end function singular_region_match
+
+@ %def singular_region_match
 @
 <<fks regions: types>>=
   type :: resonance_mapping_t
     type(resonance_history_t), dimension(:), allocatable :: res_histories
     integer, dimension(:), allocatable :: alr_to_i_res
     integer, dimension(:,:), allocatable :: i_res_to_alr
     type(vector4_t), dimension(:), allocatable :: p_res
   contains
   <<fks regions: resonance mapping: TBP>>
   end type resonance_mapping_t
 
 @ %def resonance_mapping_t
 @ Testing: Init resonance mapping for $\mu \mu b b$ final state.
 <<fks regions: resonance mapping: TBP>>=
   procedure :: init => resonance_mapping_init
 <<fks regions: procedures>>=
   subroutine resonance_mapping_init (res_map, res_hist)
     class(resonance_mapping_t), intent(inout) :: res_map
     type(resonance_history_t), intent(in), dimension(:) :: res_hist
     integer :: n_hist, i_hist1, i_hist2, n_contributors
     n_contributors = 0
     n_hist = size (res_hist)
     allocate (res_map%res_histories (n_hist))
     do i_hist1 = 1, n_hist
        if (i_hist1 + 1 <= n_hist) then
           do i_hist2 = i_hist1 + 1, n_hist
              if (.not. (res_hist(i_hist1) .contains. res_hist(i_hist2))) &
                 n_contributors = n_contributors + res_hist(i_hist2)%n_resonances
           end do
        else
           n_contributors = n_contributors + res_hist(i_hist1)%n_resonances
        end if
     end do
     allocate (res_map%p_res (n_contributors))
     res_map%res_histories = res_hist
     res_map%p_res = vector4_null
   end subroutine resonance_mapping_init
 
 @ %def resonance_mapping_init
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: set_alr_to_i_res => resonance_mapping_set_alr_to_i_res
 <<fks regions: procedures>>=
   subroutine resonance_mapping_set_alr_to_i_res (res_map, regions, alr_new_to_old)
      class(resonance_mapping_t), intent(inout) :: res_map
      type(singular_region_t), intent(in), dimension(:) :: regions
      integer, intent(out), dimension(:), allocatable :: alr_new_to_old
      integer :: alr, i_res
      integer :: alr_new, n_alr_res
      integer :: k
      if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_set_alr_to_i_res")
      n_alr_res = 0
      do alr = 1, size (regions)
         do i_res = 1, size (res_map%res_histories)
            if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) &
               n_alr_res = n_alr_res + 1
         end do
      end do
 
      allocate (res_map%alr_to_i_res (n_alr_res))
      allocate (res_map%i_res_to_alr (size (res_map%res_histories), 10))
      res_map%i_res_to_alr = 0
      allocate (alr_new_to_old (n_alr_res))
      alr_new = 1
      do alr = 1, size (regions)
         do i_res = 1, size (res_map%res_histories)
            if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then
               res_map%alr_to_i_res (alr_new) = i_res
               alr_new_to_old (alr_new) = alr
               alr_new = alr_new  + 1
            end if
         end do
      end do
 
      do i_res = 1, size (res_map%res_histories)
         k = 1
         do alr = 1, size (regions)
            if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then
               res_map%i_res_to_alr (i_res, k) = alr
               k = k + 1
            end if
         end do
      end do
      if (debug_active (D_SUBTRACTION)) then
         print *, 'i_res_to_alr:'
         do i_res = 1, size(res_map%i_res_to_alr, dim=1)
            print *, res_map%i_res_to_alr (i_res, :)
         end do
         print *, 'alr_new_to_old:', alr_new_to_old
      end if
   end subroutine resonance_mapping_set_alr_to_i_res
 
 @ %def resonance_mapping_set_alr_to_i_res
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_resonance_history => resonance_mapping_get_resonance_history
 <<fks regions: procedures>>=
   function resonance_mapping_get_resonance_history (res_map, alr) result (res_hist)
      type(resonance_history_t) :: res_hist
      class(resonance_mapping_t), intent(in) :: res_map
      integer, intent(in) :: alr
      res_hist = res_map%res_histories(res_map%alr_to_i_res (alr))
   end function resonance_mapping_get_resonance_history
 
 @ %def resonance_mapping_get_resonance_history
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: write => resonance_mapping_write
 <<fks regions: procedures>>=
   subroutine resonance_mapping_write (res_map)
     class(resonance_mapping_t), intent(in) :: res_map
     integer :: i_res
     do i_res = 1, size (res_map%res_histories)
        call res_map%res_histories(i_res)%write ()
     end do
   end subroutine resonance_mapping_write
 
 @ %def resonance_mapping_write
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_resonance_value => resonance_mapping_get_resonance_value
 <<fks regions: procedures>>=
   function resonance_mapping_get_resonance_value (res_map, i_res, p, i_gluon) result (p_map)
     real(default) :: p_map
     class(resonance_mapping_t), intent(in) :: res_map
     integer, intent(in) :: i_res
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), optional :: i_gluon
     p_map = res_map%res_histories(i_res)%mapping (p, i_gluon)
   end function resonance_mapping_get_resonance_value
 
 @ %def resonance_mapping_get_resonance_value
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_resonance_all => resonance_mapping_get_resonance_all
 <<fks regions: procedures>>=
   function resonance_mapping_get_resonance_all (res_map, alr, p, i_gluon) result (p_map)
     real(default) :: p_map
     class(resonance_mapping_t), intent(in) :: res_map
     integer, intent(in) :: alr
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), optional :: i_gluon
     integer :: i_res
     p_map = zero
     do i_res = 1, size (res_map%res_histories)
        associate (res => res_map%res_histories(i_res))
           if (any (res_map%i_res_to_alr (i_res, :) == alr)) &
              p_map = p_map + res%mapping (p, i_gluon)
        end associate
     end do
   end function resonance_mapping_get_resonance_all
 
 @ %def resonance_mapping_get_resonance_all
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_weight => resonance_mapping_get_weight
 <<fks regions: procedures>>=
   function resonance_mapping_get_weight (res_map, alr, p) result (pfr)
     real(default) :: pfr
     class(resonance_mapping_t), intent(in) :: res_map
     integer, intent(in) :: alr
     type(vector4_t), intent(in), dimension(:) :: p
     real(default) :: sumpfr
     integer :: i_res
     sumpfr = zero
     do i_res = 1, size (res_map%res_histories)
        sumpfr = sumpfr + res_map%get_resonance_value (i_res, p)
     end do
     pfr = res_map%get_resonance_value (res_map%alr_to_i_res (alr), p) / sumpfr
   end function resonance_mapping_get_weight
 
 @ %def resonance_mapping_get_weight
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_resonance_alr => resonance_mapping_get_resonance_alr
 <<fks regions: procedures>>=
   function resonance_mapping_get_resonance_alr (res_map, alr, p, i_gluon) result (p_map)
     real(default) :: p_map
     class(resonance_mapping_t), intent(in) :: res_map
     integer, intent(in) :: alr
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), optional :: i_gluon
     integer :: i_res
     i_res = res_map%alr_to_i_res (alr)
     p_map = res_map%res_histories(i_res)%mapping (p, i_gluon)
   end function resonance_mapping_get_resonance_alr
 
 @ %def resonance_mapping_get_resonance_alr
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure resonance_mapping_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine resonance_mapping_assign (res_map_out, res_map_in)
     type(resonance_mapping_t), intent(out) :: res_map_out
     type(resonance_mapping_t), intent(in) :: res_map_in
     if (allocated (res_map_in%res_histories)) then
        allocate (res_map_out%res_histories (size (res_map_in%res_histories)))
        res_map_out%res_histories = res_map_in%res_histories
     end if
     if (allocated (res_map_in%alr_to_i_res)) then
        allocate (res_map_out%alr_to_i_res (size (res_map_in%alr_to_i_res)))
        res_map_out%alr_to_i_res = res_map_in%alr_to_i_res
     end if
     if (allocated (res_map_in%i_res_to_alr)) then
        allocate (res_map_out%i_res_to_alr &
           (size (res_map_in%i_res_to_alr, 1), size (res_map_in%i_res_to_alr, 2)))
        res_map_out%i_res_to_alr = res_map_in%i_res_to_alr
     end if
     if (allocated (res_map_in%p_res)) then
        allocate (res_map_out%p_res (size (res_map_in%p_res)))
        res_map_out%p_res = res_map_in%p_res
     end if
   end subroutine resonance_mapping_assign
 
 @ %def resonance_mapping_assign
 @ Every FKS mapping should store the $\sum_\alpha d_{ij}^{-1}$ and
 $\sum_\alpha d_{ij,\rm{soft}}^{-1}$.
 Also we keep the option open to use a normlization factor, which ensures
 $\sum_\alpha S_\alpha = 1$.
 <<fks regions: types>>=
   type, abstract :: fks_mapping_t
      real(default) :: sumdij
      real(default) :: sumdij_soft
      logical :: pseudo_isr = .false.
      real(default) :: normalization_factor = one
   contains
   <<fks regions: fks mapping: TBP>>
   end type fks_mapping_t
 
 @ %def fks_mapping_t
 @
 <<fks regions: public>>=
   public :: fks_mapping_default_t
 <<fks regions: types>>=
   type, extends (fks_mapping_t) :: fks_mapping_default_t
     real(default) :: exp_1, exp_2
     integer :: n_in
   contains
   <<fks regions: fks mapping default: TBP>>
   end type fks_mapping_default_t
 
 @ %def fks_mapping_default_t
 @
 <<fks regions: public>>=
   public :: fks_mapping_resonances_t
 <<fks regions: types>>=
   type, extends (fks_mapping_t) :: fks_mapping_resonances_t
     real(default) :: exp_1, exp_2
     type(resonance_mapping_t) :: res_map
     integer :: i_con = 0
   contains
   <<fks regions: fks mapping resonances: TBP>>
   end type fks_mapping_resonances_t
 
 @ %def fks_mapping_resonances_t
 @
 <<fks regions: public>>=
   public :: operator(.equiv.)
   public :: operator(.equivtag.)
 <<fks regions: interfaces>>=
   interface operator(.equiv.)
     module procedure flv_structure_equivalent_no_tag
   end interface
 
   interface operator(.equivtag.)
     module procedure flv_structure_equivalent_with_tag
   end interface
 
   interface assignment(=)
     module procedure flv_structure_assign_flv
     module procedure flv_structure_assign_integer
   end interface
 
 @ %def operator_equiv
 @
 <<fks regions: public>>=
   public :: region_data_t
 <<fks regions: types>>=
   type :: region_data_t
     type(singular_region_t), dimension(:), allocatable :: regions
     type(flv_structure_t), dimension(:), allocatable :: flv_born
     type(flv_structure_t), dimension(:), allocatable :: flv_real
+    integer, dimension(:), allocatable :: eqv_flv_index_born
+    integer, dimension(:), allocatable :: eqv_flv_index_real
     integer, dimension(:), allocatable :: emitters
     integer :: n_regions = 0
     integer :: n_emitters = 0
     integer :: n_flv_born = 0
     integer :: n_flv_real = 0
     integer :: n_in = 0
     integer :: n_legs_born = 0
     integer :: n_legs_real = 0
     integer :: n_phs = 0
     class(fks_mapping_t), allocatable :: fks_mapping
     integer, dimension(:), allocatable :: resonances
     type(resonance_contributors_t), dimension(:), allocatable :: alr_contributors
     integer, dimension(:), allocatable :: alr_to_i_contributor
     integer, dimension(:), allocatable :: i_phs_to_i_con
   contains
   <<fks regions: reg data: TBP>>
   end type region_data_t
 
 @ %def region_data_t
 @
 <<fks regions: reg data: TBP>>=
   procedure :: allocate_fks_mappings => region_data_allocate_fks_mappings
 <<fks regions: procedures>>=
   subroutine region_data_allocate_fks_mappings (reg_data, mapping_type)
     class(region_data_t), intent(inout) :: reg_data
     integer, intent(in) :: mapping_type
 
     select case (mapping_type)
     case (FKS_DEFAULT)
        allocate (fks_mapping_default_t :: reg_data%fks_mapping)
     case (FKS_RESONANCES)
        allocate (fks_mapping_resonances_t :: reg_data%fks_mapping)
     case default
        call msg_fatal ("Init region_data: FKS mapping not implemented!")
     end select
   end subroutine region_data_allocate_fks_mappings
 
 @ %def region_data_allocate_fks_mappings
 @
 <<fks regions: reg data: TBP>>=
   procedure :: init => region_data_init
 <<fks regions: procedures>>=
   subroutine region_data_init (reg_data, n_in, model, flavor_born, &
          flavor_real, nlo_correction_type)
     class(region_data_t), intent(inout) :: reg_data
     integer, intent(in) :: n_in
     type(model_t), intent(in) :: model
     integer, intent(in), dimension(:,:) :: flavor_born, flavor_real
     type(ftuple_list_t), dimension(:), allocatable :: ftuples
     integer, dimension(:), allocatable :: emitter
     type(flv_structure_t), dimension(:), allocatable :: flst_alr
     integer :: i
     integer :: n_flv_real_before_check
     type(string_t), intent(in) :: nlo_correction_type
     reg_data%n_in = n_in
     reg_data%n_flv_born = size (flavor_born, dim = 2)
     reg_data%n_legs_born = size (flavor_born, dim = 1)
     reg_data%n_legs_real = reg_data%n_legs_born + 1
     n_flv_real_before_check = size (flavor_real, dim = 2)
     allocate (reg_data%flv_born (reg_data%n_flv_born))
     allocate (reg_data%flv_real (n_flv_real_before_check))
     do i = 1, reg_data%n_flv_born
        call reg_data%flv_born(i)%init (flavor_born (:, i), n_in)
     end do
     do i = 1, n_flv_real_before_check
        call reg_data%flv_real(i)%init (flavor_real (:, i), n_in)
     end do
 
     call reg_data%find_regions (model, ftuples, emitter, flst_alr)
     call reg_data%init_singular_regions (ftuples, emitter, flst_alr, nlo_correction_type)
     reg_data%n_flv_real = maxval (reg_data%regions%real_index)
     call reg_data%find_emitters ()
     call reg_data%set_mass_color_and_charge (model)
     call reg_data%set_splitting_info ()
 
   end subroutine region_data_init
 
 @ %def region_data_init
 @
 <<fks regions: reg data: TBP>>=
   procedure :: init_resonance_information => region_data_init_resonance_information
 <<fks regions: procedures>>=
   subroutine region_data_init_resonance_information (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     call reg_data%enlarge_singular_regions_with_resonances ()
     call reg_data%find_resonances ()
   end subroutine region_data_init_resonance_information
 
 @ %def region_data_init_resonance_information
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_resonance_mappings => region_data_set_resonance_mappings
 <<fks regions: procedures>>=
   subroutine region_data_set_resonance_mappings (reg_data, resonance_histories)
     class(region_data_t), intent(inout) :: reg_data
     type(resonance_history_t), intent(in), dimension(:) :: resonance_histories
     select type (map => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        call map%res_map%init (resonance_histories)
     end select
   end subroutine region_data_set_resonance_mappings
 
 @ %def region_data_set_resonance_mappings
 @
 <<fks regions: reg data: TBP>>=
   procedure :: setup_fks_mappings => region_data_setup_fks_mappings
 <<fks regions: procedures>>=
   subroutine region_data_setup_fks_mappings (reg_data, template, n_in)
     class(region_data_t), intent(inout) :: reg_data
     type(fks_template_t), intent(in) :: template
     integer, intent(in) :: n_in
     call reg_data%allocate_fks_mappings (template%mapping_type)
     select type (map => reg_data%fks_mapping)
     type is (fks_mapping_default_t)
        call map%set_parameter (n_in, template%fks_dij_exp1, template%fks_dij_exp2)
     end select
   end subroutine region_data_setup_fks_mappings
 
 @ %def region_data_setup_fks_mappings
 @ So far, we have only created singular regions for a non-resonant case. When
 resonance mappings are required, we have more singular regions, since they
 must now be identified by their emitter-resonance pair index, where the emitter
 must be compatible with the resonance.
 <<fks regions: reg data: TBP>>=
   procedure :: enlarge_singular_regions_with_resonances &
      => region_data_enlarge_singular_regions_with_resonances
 <<fks regions: procedures>>=
   subroutine region_data_enlarge_singular_regions_with_resonances (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr
     integer, dimension(:), allocatable :: alr_new_to_old
     integer :: n_alr_new
     type(singular_region_t), dimension(:), allocatable :: save_regions
     if (debug_on) call msg_debug (D_SUBTRACTION, "region_data_enlarge_singular_regions_with_resonances")
     call debug_input_values ()
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_default_t)
        return
     type is (fks_mapping_resonances_t)
        allocate (save_regions (reg_data%n_regions))
        do alr = 1, reg_data%n_regions
           save_regions(alr) = reg_data%regions(alr)
        end do
 
        associate (res_map => fks_mapping%res_map)
           call res_map%set_alr_to_i_res (reg_data%regions, alr_new_to_old)
           deallocate (reg_data%regions)
           n_alr_new = size (alr_new_to_old)
           reg_data%n_regions = n_alr_new
           allocate (reg_data%regions (n_alr_new))
           do alr = 1, n_alr_new
              reg_data%regions(alr) = save_regions(alr_new_to_old (alr))
              reg_data%regions(alr)%i_res = res_map%alr_to_i_res (alr)
           end do
        end associate
     end select
 
   contains
 
     subroutine debug_input_values ()
       if (debug2_active (D_SUBTRACTION)) then
          call reg_data%write ()
       end if
     end subroutine debug_input_values
 
   end subroutine region_data_enlarge_singular_regions_with_resonances
 
 @ %def region_data_enlarge_singular_regions_with_resonances
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_isr_pseudo_regions => region_data_set_isr_pseudo_regions
 <<fks regions: procedures>>=
   subroutine region_data_set_isr_pseudo_regions (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr
     integer :: n_alr_new
     !!! Subroutine called for threshold factorization ->
     !!! Size of singular regions at this point is fixed
     type(singular_region_t), dimension(2) :: save_regions
     integer, dimension(4) :: alr_new_to_old
     do alr = 1, reg_data%n_regions
        save_regions(alr) = reg_data%regions(alr)
     end do
     n_alr_new = reg_data%n_regions * 2
     alr_new_to_old = [1, 1, 2, 2]
     deallocate (reg_data%regions)
     allocate (reg_data%regions (n_alr_new))
     reg_data%n_regions = n_alr_new
     do alr = 1, n_alr_new
        reg_data%regions(alr) = save_regions(alr_new_to_old (alr))
        call add_pseudo_emitters (reg_data%regions(alr))
        if (mod (alr, 2) == 0) reg_data%regions(alr)%pseudo_isr = .true.
     end do
   contains
     subroutine add_pseudo_emitters (sregion)
       type(singular_region_t), intent(inout) :: sregion
       type(ftuple_t), dimension(2) :: ftuples_save
       integer :: alr
       do alr = 1, 2
          ftuples_save(alr) = sregion%ftuples(alr)
       end do
       deallocate (sregion%ftuples)
       sregion%nregions = sregion%nregions * 2
       allocate (sregion%ftuples (sregion%nregions))
       do alr = 1, sregion%nregions
          sregion%ftuples(alr) = ftuples_save (alr_new_to_old(alr))
          if (mod (alr, 2) == 0) sregion%ftuples(alr)%pseudo_isr = .true.
       end do
     end subroutine add_pseudo_emitters
   end subroutine region_data_set_isr_pseudo_regions
 
 @ %def region_data_set_isr_pseudo_regions
 @ This subroutine splits up the ftuple-list of the singular regions into interference-free
 lists, i.e. lists which only contain the same emitter. This is relevant for factorized
 NLO calculations. In the current implementation, it is hand-tailored for the threshold
 computation, but should be generalized further in the future.
 <<fks regions: reg data: TBP>>=
   procedure :: split_up_interference_regions_for_threshold => &
        region_data_split_up_interference_regions_for_threshold
 <<fks regions: procedures>>=
   subroutine region_data_split_up_interference_regions_for_threshold (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr, i_ftuple
     integer :: current_emitter
     integer :: i1, i2
     integer :: n_new_reg
     type(ftuple_t), dimension(2) :: ftuples
     do alr = 1, reg_data%n_regions
        associate (region => reg_data%regions(alr))
           current_emitter = region%emitter
           n_new_reg = 0
           do i_ftuple = 1, region%nregions
              call region%ftuples(i_ftuple)%get (i1, i2)
              if (i1 == current_emitter) then
                 n_new_reg = n_new_reg + 1
                 ftuples(n_new_reg) = region%ftuples(i_ftuple)
              end if
           end do
           deallocate (region%ftuples)
           allocate (region%ftuples(n_new_reg))
           region%ftuples = ftuples (1 : n_new_reg)
           region%nregions = n_new_reg
        end associate
     end do
     reg_data%fks_mapping%normalization_factor = 0.5_default
   end subroutine region_data_split_up_interference_regions_for_threshold
 
 @ %def region_data_split_up_interference_regions_for_threshold
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_mass_color_and_charge => region_data_set_mass_color_and_charge
 <<fks regions: procedures>>=
   subroutine region_data_set_mass_color_and_charge (reg_data, model)
     class(region_data_t), intent(inout) :: reg_data
     type(model_t), intent(in) :: model
     integer :: i
     do i = 1, reg_data%n_regions
        associate (region => reg_data%regions(i))
           call region%flst_uborn%init_mass_color_and_charge (model)
           call region%flst_real%init_mass_color_and_charge (model)
        end associate
     end do
     do i = 1, reg_data%n_flv_born
        call reg_data%flv_born(i)%init_mass_color_and_charge (model)
     end do
     do i = 1, size (reg_data%flv_real)
        call reg_data%flv_real(i)%init_mass_color_and_charge (model)
     end do
   end subroutine region_data_set_mass_color_and_charge
 
 @ %def region_data_set_mass_color_and_charge
 @
 <<fks regions: reg data: TBP>>=
   procedure :: uses_resonances => region_data_uses_resonances
 <<fks regions: procedures>>=
   function region_data_uses_resonances (reg_data) result (val)
     logical :: val
     class(region_data_t), intent(in) :: reg_data
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        val = .true.
     class default
        val = .false.
     end select
   end function region_data_uses_resonances
 
 @ %def region_data_uses_resonances
 @ Creates a list containing the emitter of each singular region.
 <<fks regions: reg data: TBP>>=
   procedure :: get_emitter_list => region_data_get_emitter_list
 <<fks regions: procedures>>=
   pure function region_data_get_emitter_list (reg_data) result (emitters)
     class(region_data_t), intent(in) :: reg_data
     integer, dimension(:), allocatable :: emitters
     integer :: i
     allocate (emitters (reg_data%n_regions))
     do i = 1, reg_data%n_regions
        emitters(i) = reg_data%regions(i)%emitter
     end do
   end function region_data_get_emitter_list
 
 @ %def region_data_get_emitter_list
 @ Returns the number of emitters not equal to 0 to avoid double counting
 between emitters 0, 1 and 2.
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_emitters_sc => region_data_get_n_emitters_sc
 <<fks regions: procedures>>=
   function region_data_get_n_emitters_sc (reg_data) result (n_emitters_sc)
     class(region_data_t), intent(in) :: reg_data
     integer :: n_emitters_sc
     n_emitters_sc = count (reg_data%emitters /= 0)
   end function region_data_get_n_emitters_sc
 
 @ %def region_data_get_n_emitters_sc
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_associated_resonances => region_data_get_associated_resonances
 <<fks regions: procedures>>=
   function region_data_get_associated_resonances (reg_data, emitter) result (res)
     integer, dimension(:), allocatable :: res
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: emitter
     integer :: alr, i
     integer :: n_res
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        n_res = 0
 
        do alr = 1, reg_data%n_regions
           if (reg_data%regions(alr)%emitter == emitter) &
              n_res = n_res + 1
        end do
 
        if (n_res > 0) then
           allocate (res (n_res))
        else
           return
        end if
        i = 1
 
        do alr = 1, reg_data%n_regions
           if (reg_data%regions(alr)%emitter == emitter) then
              res (i) = fks_mapping%res_map%alr_to_i_res (alr)
              i = i + 1
           end if
        end do
     end select
   end function region_data_get_associated_resonances
 
 @ %def region_data_get_associated_resonances
 @
 <<fks regions: reg data: TBP>>=
   procedure :: emitter_is_compatible_with_resonance => &
      region_data_emitter_is_compatible_with_resonance
 <<fks regions: procedures>>=
   function region_data_emitter_is_compatible_with_resonance &
      (reg_data, i_res, emitter) result (compatible)
      logical :: compatible
      class(region_data_t), intent(in) :: reg_data
      integer, intent(in) :: i_res, emitter
      integer :: i_res_alr, alr
      compatible = .false.
      select type (fks_mapping => reg_data%fks_mapping)
      type is (fks_mapping_resonances_t)
         do alr = 1, reg_data%n_regions
            i_res_alr = fks_mapping%res_map%alr_to_i_res (alr)
            if (i_res_alr == i_res .and. reg_data%get_emitter(alr) == emitter) then
               compatible = .true.
               exit
            end if
         end do
      end select
   end function region_data_emitter_is_compatible_with_resonance
 
 @ %def region_data_emitter_is_compatible_with_resonance
 @
 <<fks regions: reg data: TBP>>=
   procedure :: emitter_is_in_resonance => region_data_emitter_is_in_resonance
 <<fks regions: procedures>>=
   function region_data_emitter_is_in_resonance (reg_data, i_res, emitter) result (exist)
     logical :: exist
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_res, emitter
     integer :: i
     exist = .false.
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        associate (res_history => fks_mapping%res_map%res_histories(i_res))
           do i = 1, res_history%n_resonances
              exist = exist .or. any (res_history%resonances(i)%contributors%c == emitter)
           end do
       end associate
     end select
   end function region_data_emitter_is_in_resonance
 
 @ %def region_data_emitter_is_in_resonance
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_contributors => region_data_get_contributors
 <<fks regions: procedures>>=
   subroutine region_data_get_contributors (reg_data, i_res, emitter, c, success)
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_res, emitter
     integer, intent(inout), dimension(:), allocatable :: c
     logical, intent(out) :: success
     integer :: i
     success = .false.
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        associate (res_history => fks_mapping%res_map%res_histories (i_res))
           do i = 1, res_history%n_resonances
              if (any (res_history%resonances(i)%contributors%c == emitter)) then
                 allocate (c (size (res_history%resonances(i)%contributors%c)))
                 c = res_history%resonances(i)%contributors%c
                 success = .true.
                 exit
              end if
           end do
        end associate
     end select
   end subroutine region_data_get_contributors
 
 @ %def region_data_get_contributors
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_emitter => region_data_get_emitter
 <<fks regions: procedures>>=
   pure function region_data_get_emitter (reg_data, alr) result (emitter)
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: alr
     integer :: emitter
     emitter = reg_data%regions(alr)%emitter
   end function region_data_get_emitter
 
 @ %def region_data_get_emitter
 @
 <<fks regions: reg data: TBP>>=
   procedure :: map_real_to_born_index => region_data_map_real_to_born_index
 <<fks regions: procedures>>=
   function region_data_map_real_to_born_index (reg_data, real_index) result (uborn_index)
     integer :: uborn_index
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: real_index
     integer :: alr
     uborn_index = 0
     do alr = 1, size (reg_data%regions)
        if (reg_data%regions(alr)%real_index == real_index) then
           uborn_index = reg_data%regions(alr)%uborn_index
           exit
        end if
     end do
   end function region_data_map_real_to_born_index
 
 @ %def region_data_map_real_to_born_index
 @
 <<fks regions: reg data: TBP>>=
   generic :: get_flv_states_born => get_flv_states_born_single, get_flv_states_born_array
   procedure :: get_flv_states_born_single => region_data_get_flv_states_born_single
   procedure :: get_flv_states_born_array => region_data_get_flv_states_born_array
 <<fks regions: procedures>>=
   function region_data_get_flv_states_born_array (reg_data) result (flv_states)
     integer, dimension(:,:), allocatable :: flv_states
     class(region_data_t), intent(in) :: reg_data
     integer :: i_flv
     allocate (flv_states (reg_data%n_legs_born, reg_data%n_flv_born))
     do i_flv = 1, reg_data%n_flv_born
        flv_states (:, i_flv) = reg_data%flv_born(i_flv)%flst
     end do
   end function region_data_get_flv_states_born_array
 
   function region_data_get_flv_states_born_single (reg_data, i_flv) result (flv_states)
     integer, dimension(:), allocatable :: flv_states
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_flv
     allocate (flv_states (reg_data%n_legs_born))
     flv_states = reg_data%flv_born(i_flv)%flst
   end function region_data_get_flv_states_born_single
 
 @ %def region_data_get_flv_states_born
 @
 <<fks regions: reg data: TBP>>=
   generic :: get_flv_states_real => get_flv_states_real_single, get_flv_states_real_array
   procedure :: get_flv_states_real_single => region_data_get_flv_states_real_single
   procedure :: get_flv_states_real_array => region_data_get_flv_states_real_array
 <<fks regions: procedures>>=
   function region_data_get_flv_states_real_single (reg_data, i_flv) result (flv_states)
     integer, dimension(:), allocatable :: flv_states
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_flv
     integer :: i_reg
     allocate (flv_states (reg_data%n_legs_real))
     do i_reg = 1, reg_data%n_regions
        if (i_flv == reg_data%regions(i_reg)%real_index) then
           flv_states = reg_data%regions(i_reg)%flst_real%flst
           exit
        end if
     end do
   end function region_data_get_flv_states_real_single
 
   function region_data_get_flv_states_real_array (reg_data) result (flv_states)
     integer, dimension(:,:), allocatable :: flv_states
     class(region_data_t), intent(in) :: reg_data
     integer :: i_flv
     allocate (flv_states (reg_data%n_legs_real, reg_data%n_flv_real))
     do i_flv = 1, reg_data%n_flv_real
        flv_states (:, i_flv) = reg_data%get_flv_states_real (i_flv)
     end do
   end function region_data_get_flv_states_real_array
 
 @ %def region_data_get_flv_states_real
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_all_flv_states => region_data_get_all_flv_states
 <<fks regions: procedures>>=
   subroutine region_data_get_all_flv_states (reg_data, flv_born, flv_real)
      class(region_data_t), intent(in) :: reg_data
      integer, dimension(:,:), allocatable, intent(out) :: flv_born, flv_real
      allocate (flv_born (reg_data%n_legs_born, reg_data%n_flv_born))
      flv_born = reg_data%get_flv_states_born ()
      allocate (flv_real (reg_data%n_legs_real, reg_data%n_flv_real))
      flv_real = reg_data%get_flv_states_real ()
   end subroutine region_data_get_all_flv_states
 
 @ %def region_data_get_all_flv_states
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_in => region_data_get_n_in
 <<fks regions: procedures>>=
   function region_data_get_n_in (reg_data) result (n_in)
     integer :: n_in
     class(region_data_t), intent(in) :: reg_data
     n_in = reg_data%n_in
   end function region_data_get_n_in
 
 @ %def region_data_get_n_in
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_legs_real => region_data_get_n_legs_real
 <<fks regions: procedures>>=
   function region_data_get_n_legs_real (reg_data) result (n_legs)
     integer :: n_legs
     class(region_data_t), intent(in) :: reg_data
     n_legs = reg_data%n_legs_real
   end function region_data_get_n_legs_real
 
 @ %def region_data_get_n_legs_real
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_legs_born => region_data_get_n_legs_born
 <<fks regions: procedures>>=
   function region_data_get_n_legs_born (reg_data) result (n_legs)
     integer :: n_legs
     class(region_data_t), intent(in) :: reg_data
     n_legs = reg_data%n_legs_born
   end function region_data_get_n_legs_born
 
 @ %def region_data_get_n_legs_born
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_flv_real => region_data_get_n_flv_real
 <<fks regions: procedures>>=
   function region_data_get_n_flv_real (reg_data) result (n_flv)
     integer :: n_flv
     class(region_data_t), intent(in) :: reg_data
     n_flv = reg_data%n_flv_real
   end function region_data_get_n_flv_real
 
 @ %def region_data_get_n_flv_real
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_flv_born => region_data_get_n_flv_born
 <<fks regions: procedures>>=
   function region_data_get_n_flv_born (reg_data) result (n_flv)
     integer :: n_flv
     class(region_data_t), intent(in) :: reg_data
     n_flv = reg_data%n_flv_born
   end function region_data_get_n_flv_born
 
 @ %def region_data_get_n_flv_born
 
 @ Returns $S_i = \frac{1}{\mathcal{D}d_i}$ or $S_{ij} =
 \frac{1}{\mathcal{D}d_{ij}}$ for one particular singular region.  At
 this point, the flavor array should be rearranged in such a way that
 the emitted particle is at the last position of
 the flavor structure list.
 <<fks regions: reg data: TBP>>=
   generic :: get_svalue => get_svalue_last_pos, get_svalue_ij
   procedure :: get_svalue_last_pos => region_data_get_svalue_last_pos
   procedure :: get_svalue_ij => region_data_get_svalue_ij
 <<fks regions: procedures>>=
   function region_data_get_svalue_ij (reg_data, p_real, alr, i, j, i_res) result (sval)
     class(region_data_t), intent(inout) :: reg_data
     type(vector4_t), intent(in), dimension(:) :: p_real
     integer, intent(in) :: alr, i, j
     integer, intent(in) :: i_res
     real(default) :: sval
     associate (map => reg_data%fks_mapping)
        call map%compute_sumdij (reg_data%regions(alr), p_real)
        select type (map)
        type is (fks_mapping_resonances_t)
           map%i_con = reg_data%alr_to_i_contributor (alr)
        end select
        map%pseudo_isr = reg_data%regions(alr)%pseudo_isr
        sval = map%svalue (p_real, i, j, i_res) * map%normalization_factor
     end associate
   end function region_data_get_svalue_ij
 
   function region_data_get_svalue_last_pos (reg_data, p, alr, emitter, i_res) result (sval)
     class(region_data_t), intent(inout) :: reg_data
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: alr, emitter
     integer, intent(in) :: i_res
     real(default) :: sval
     sval = reg_data%get_svalue (p, alr, emitter, reg_data%n_legs_real, i_res)
   end function region_data_get_svalue_last_pos
 
 @ %def region_data_get_svalue
 @ The same as above, but for the soft limit.
 <<fks regions: reg data: TBP>>=
   procedure :: get_svalue_soft => region_data_get_svalue_soft
 <<fks regions: procedures>>=
   function region_data_get_svalue_soft &
        (reg_data, p_born, p_soft, alr, emitter, i_res) result (sval)
     class(region_data_t), intent(inout) :: reg_data
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     integer, intent(in) :: alr, emitter, i_res
     real(default) :: sval
     associate (map => reg_data%fks_mapping)
        call map%compute_sumdij_soft (reg_data%regions(alr), p_born, p_soft)
        select type (map)
        type is (fks_mapping_resonances_t)
           map%i_con = reg_data%alr_to_i_contributor (alr)
        end select
        map%pseudo_isr = reg_data%regions(alr)%pseudo_isr
        sval = map%svalue_soft (p_born, p_soft, emitter, i_res) * map%normalization_factor
     end associate
   end function region_data_get_svalue_soft
 
 @ %def region_data_get_svalue_soft
 @ This subroutine starts with a specification of $N$- and
 $N+1$-particle configurations, [[flst_born]] and [[flst_real]], saved
 in [[reg_data]]. From these, it creates a list of fundamental tuples,
 a list of emitters and a list containing the $N+1$-particle
 configuration, rearranged  in such a way that the emitter-radiation
 pair is last ([[flst_alr]]). For the $e^+ \, e^- \, \rightarrow u \,
 \bar{u} \, g$- example, the generated objects are shown in table
 \ref{table:ftuples and flavors}. Note that at this point, [[flst_alr]]
 is arranged in such a way that the emitter can only be equal to
 $n_{legs}-1$ for final-state radiation or 0, 1, or 2 for initial-state
 radiation. Further, it occurs that regions can be equivalent. For
 example in table \ref{table:ftuples and flavors} the regions
 corresponding to \texttt{alr} = 1 and \texttt{alr} = 3 as well as
 \texttt{alr} = 2 and \texttt{alr} = 4 describe the same physics and
 are therefore equivalent.
 @
 <<fks regions: reg data: TBP>>=
   procedure :: find_regions => region_data_find_regions
 <<fks regions: procedures>>=
   subroutine region_data_find_regions &
        (reg_data, model, ftuples, emitters, flst_alr)
     class(region_data_t), intent(in) :: reg_data
     type(model_t), intent(in) :: model
     type(ftuple_list_t), intent(out), dimension(:), allocatable :: ftuples
     integer, intent(out), dimension(:), allocatable :: emitters
     type(flv_structure_t), intent(out), dimension(:), allocatable :: flst_alr
     type(ftuple_list_t), dimension(:,:), allocatable :: ftuples_tmp
     integer, dimension(:,:), allocatable :: ftuple_index
     integer :: n_born, n_real
     integer :: n_legreal
     integer :: i_born, i_real, i_ftuple
     integer :: last_registered_i_born, last_registered_i_real
 
     n_born = size (reg_data%flv_born)
     n_real = size (reg_data%flv_real)
     n_legreal = size (reg_data%flv_real(1)%flst)
     allocate (emitters (0))
     allocate (flst_alr (0))
     allocate (ftuples (0))
     i_ftuple = 0
     last_registered_i_born = 0; last_registered_i_real = 0
 
     do i_real = 1, n_real
        do i_born = 1, n_born
           call setup_flsts_emitters_and_ftuples_fsr &
                (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples)
           call setup_flsts_emitters_and_ftuples_isr &
                (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples)
        end do
     end do
 
   contains
     function incr_i_ftuple_if_required (i_born, i_real, i_ftuple_in) result (i_ftuple)
       integer :: i_ftuple
       integer, intent(in) :: i_born, i_real, i_ftuple_in
       if (last_registered_i_born /= i_born .or. last_registered_i_real /= i_real) then
          last_registered_i_born = i_born
          last_registered_i_real = i_real
          i_ftuple = i_ftuple_in + 1
       else
          i_ftuple = i_ftuple_in
       end if
     end function incr_i_ftuple_if_required
 
     subroutine setup_flsts_emitters_and_ftuples_fsr &
            (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples)
       integer, intent(in) :: i_real, i_born
       integer, intent(inout) :: i_ftuple
       type(flv_structure_t), intent(inout), dimension(:), allocatable :: flst_alr
       integer, intent(inout), dimension(:), allocatable :: emitters
       type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
       type(ftuple_list_t) :: ftuples_tmp
       type(flv_structure_t) :: flst_alr_tmp
       type(ftuple_t) :: current_ftuple
       integer :: leg1, leg2
       logical :: valid1, valid2
       associate (flv_born => reg_data%flv_born(i_born), &
               flv_real => reg_data%flv_real(i_real))
          do leg1 = reg_data%n_in + 1, n_legreal
             do leg2 = leg1 + 1, n_legreal
                valid1 = flv_real%valid_pair(leg1, leg2, flv_born, model)
                valid2 = flv_real%valid_pair(leg2, leg1, flv_born, model)
                if (valid1 .or. valid2) then
                   if(valid1) then
                      flst_alr_tmp = create_alr (flv_real, &
                           reg_data%n_in, leg1, leg2)
                   else
                      flst_alr_tmp = create_alr (flv_real, &
                           reg_data%n_in, leg2, leg1)
                   end if
                   flst_alr = [flst_alr, flst_alr_tmp]
                   emitters = [emitters, n_legreal - 1]
                   call current_ftuple%set (leg1, leg2)
                   call current_ftuple%determine_splitting_type_fsr &
                        (flv_real, leg1, leg2)
                   i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple)
                   if (i_ftuple > size (ftuples)) then
                      call ftuples_tmp%append (current_ftuple)
                      ftuples = [ftuples, ftuples_tmp]
                   else
                      call ftuples(i_ftuple)%append (current_ftuple)
                   end if
                end if
             end do
          end do
       end associate
     end subroutine setup_flsts_emitters_and_ftuples_fsr
 
     subroutine setup_flsts_emitters_and_ftuples_isr &
            (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples)
       integer, intent(in) :: i_real, i_born
       integer, intent(inout) :: i_ftuple
       type(flv_structure_t), intent(inout), dimension(:), allocatable :: flst_alr
       integer, intent(inout), dimension(:), allocatable :: emitters
       type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
       type(ftuple_list_t) :: ftuples_tmp
       type(flv_structure_t) :: flst_alr_tmp
       type(ftuple_t) :: current_ftuple
       integer :: leg, emitter
       logical :: valid1, valid2
       associate (flv_born => reg_data%flv_born(i_born), &
               flv_real => reg_data%flv_real(i_real))
          do leg = reg_data%n_in + 1, n_legreal
             valid1 = flv_real%valid_pair(1, leg, flv_born, model)
             if (reg_data%n_in > 1) then
                valid2 = flv_real%valid_pair(2, leg, flv_born, model)
             else
                valid2 = .false.
             end if
             if (valid1 .and. valid2) then
                emitter = 0
             else if (valid1 .and. .not. valid2) then
                emitter = 1
             else if (.not. valid1 .and. valid2) then
                emitter = 2
             else
                emitter = -1
             end if
             if (valid1 .or. valid2) then
                flst_alr_tmp = create_alr (flv_real, reg_data%n_in, emitter, leg)
                flst_alr = [flst_alr, flst_alr_tmp]
                emitters = [emitters, emitter]
                call current_ftuple%set(emitter, leg)
                call current_ftuple%determine_splitting_type_isr &
                     (flv_real, emitter, leg)
                i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple)
                if (i_ftuple > size (ftuples)) then
                   call ftuples_tmp%append (current_ftuple)
                   ftuples = [ftuples, ftuples_tmp]
                else
                   call ftuples(i_ftuple)%append (current_ftuple)
                end if
             end if
          end do
       end associate
     end subroutine setup_flsts_emitters_and_ftuples_isr
 
   end subroutine region_data_find_regions
 
 @ %def region_data_find_regions
+@ We transfer the mapping of flavor structures that lead to the same amplitude
+(with structure functions already accounted for!) to the Born and real
+[[flv_structure]] of each [[singular_region]].
+We then use this information, besides other data of each [[singular_region]],
+to determine which produce the same amplitude for the non-subtracted real
+and real subtraction terms and set up the equivalence index mapping for
+each region.
+<<fks regions: reg data: TBP>>=
+  procedure :: find_eqv_regions => region_data_find_eqv_regions
+<<fks regions: procedures>>=
+  subroutine region_data_find_eqv_regions (reg_data, optimize)
+    class(region_data_t), intent(inout) :: reg_data
+    logical, intent(in) :: optimize
+    integer :: n_reg, alr1, alr2
+    n_reg = reg_data%n_regions
+    if (optimize) then
+       do alr1 = 1, n_reg
+          reg_data%regions(alr1)%flst_uborn%eqv_index = &
+               reg_data%eqv_flv_index_born(reg_data%regions(alr1)%uborn_index)
+          reg_data%regions(alr1)%flst_real%eqv_index = &
+               reg_data%eqv_flv_index_real(reg_data%regions(alr1)%real_index)
+       end do
+       do alr1 = 1, n_reg
+          do alr2 = 1, alr1
+             if (reg_data%regions(alr2) .match. reg_data%regions(alr1)) then
+                reg_data%regions(alr1)%eqv_index = alr2
+                exit
+             end if
+          end do
+       end do
+    else
+       do alr1 = 1, n_reg
+          reg_data%regions(alr1)%eqv_index = alr1
+       end do
+    end if
+  end subroutine region_data_find_eqv_regions
+
+@ %def region_data_find_eqv_regions
 @ Creates singular regions according to table \ref{table:singular
 regions}. It scans all regions in table \ref{table:ftuples and
 flavors} and records the real flavor structures. If they are
 equivalent, the flavor structure is not recorded, but the multiplicity
 of the present one is increased.
 <<fks regions: reg data: TBP>>=
   procedure :: init_singular_regions => region_data_init_singular_regions
 <<fks regions: procedures>>=
   subroutine region_data_init_singular_regions &
          (reg_data, ftuples, emitter, flv_alr, nlo_correction_type)
     class(region_data_t), intent(inout) :: reg_data
     type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
     type(string_t), intent(in) :: nlo_correction_type
     integer :: n_independent_flv
     integer, intent(in), dimension(:) :: emitter
     type(flv_structure_t), intent(in), dimension(:) :: flv_alr
     type(flv_structure_t), dimension(:), allocatable :: flv_uborn, flv_alr_registered
     integer, dimension(:), allocatable :: mult
     integer, dimension(:), allocatable :: flst_emitter
     integer :: n_regions, maxregions
     integer, dimension(:), allocatable :: index
     integer :: i, i_flv, n_legs
     logical :: equiv, valid_fs_splitting
     integer :: i_first, i_reg, i_reg_prev
     integer, dimension(:), allocatable :: region_to_ftuple, alr_limits
     integer, dimension(:), allocatable :: equiv_index
 
     maxregions = size (emitter)
     n_legs = flv_alr(1)%nlegs
 
     allocate (flv_uborn (maxregions))
     allocate (flv_alr_registered (maxregions))
     allocate (mult (maxregions))
     mult = 0
     allocate (flst_emitter (maxregions))
     allocate (index (0))
     allocate (region_to_ftuple (maxregions))
     allocate (equiv_index (maxregions))
 
     call setup_region_mappings (n_independent_flv, alr_limits, region_to_ftuple)
     i_first = 1
     i_reg = 1
     SCAN_FLAVORS: do i_flv = 1, n_independent_flv
        SCAN_FTUPLES: do i = i_first, i_first + alr_limits (i_flv) - 1
           equiv = .false.
           if (i == i_first) then
              flv_alr_registered(i_reg) = flv_alr(i)
              mult(i_reg) = mult(i_reg) + 1
              flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), nlo_correction_type)
              flst_emitter(i_reg) = emitter(i)
              index = [index, region_to_real_index(ftuples, i)]
              equiv_index(i_reg) = region_to_ftuple(i)
              i_reg  = i_reg + 1
           else
              !!! Check for equivalent flavor structures
              do i_reg_prev = 1, i_reg - 1
                 if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) > reg_data%n_in) then
                    valid_fs_splitting = check_fs_splitting (flv_alr(i)%get_last_two(n_legs), &
                           flv_alr_registered(i_reg_prev)%get_last_two(n_legs), &
                           flv_alr(i)%tag(n_legs - 1), flv_alr_registered(i_reg_prev)%tag(n_legs - 1))
                    if ((flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) &
                         .and. valid_fs_splitting) then
                       mult(i_reg_prev) = mult(i_reg_prev) + 1
                       equiv = .true.
                       call ftuples(region_to_real_index(ftuples, i))%set_equiv &
                            (equiv_index(i_reg_prev), region_to_ftuple(i))
                       exit
                    end if
                 else if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) <= reg_data%n_in) then
                    if (flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) then
                       mult(i_reg_prev) = mult(i_reg_prev) + 1
                       equiv = .true.
                       call ftuples(region_to_real_index(ftuples, i))%set_equiv &
                            (equiv_index(i_reg_prev), region_to_ftuple(i))
                       exit
                    end if
                 end if
              end do
              if (.not. equiv) then
                 flv_alr_registered(i_reg) = flv_alr(i)
                 mult(i_reg) = mult(i_reg) + 1
                 flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), nlo_correction_type)
                 flst_emitter(i_reg) = emitter(i)
                 index = [index, region_to_real_index(ftuples, i)]
                 equiv_index (i_reg) = region_to_ftuple(i)
                 i_reg = i_reg + 1
              end if
           end if
        end do SCAN_FTUPLES
        i_first = i_first + alr_limits(i_flv)
     end do SCAN_FLAVORS
     n_regions = i_reg - 1
 
     allocate (reg_data%regions (n_regions))
     reg_data%n_regions = n_regions
     call account_for_regions_from_other_uborns (ftuples)
     call init_regions_with_permuted_flavors ()
     call assign_real_indices ()
 
     deallocate (flv_uborn)
     deallocate (flv_alr_registered)
     deallocate (mult)
     deallocate (flst_emitter)
     deallocate (index)
     deallocate (region_to_ftuple)
     deallocate (equiv_index)
 
   contains
 
     subroutine account_for_regions_from_other_uborns (ftuples)
       type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
       integer :: alr1, alr2, i
       type(ftuple_t), dimension(:), allocatable :: ftuples_alr1, ftuples_alr2
       type(flavor_permutation_t) :: perm_list
       logical, dimension(:,:), allocatable :: equivalences
       do alr1 = 1, n_regions
          do alr2 = 1, n_regions
             if (index(alr1) == index(alr2)) cycle
             if (flv_alr_registered(alr1) .equiv. flv_alr_registered(alr2)) then
                call ftuples(index(alr1))%to_array (ftuples_alr1, equivalences, .false.)
                call ftuples(index(alr2))%to_array (ftuples_alr2, equivalences, .false.)
                do i = 1, size (ftuples_alr2)
                   if (.not. any (ftuple_equal_ireg (ftuples_alr1, ftuples_alr2(i)))) then
                      call ftuples(index(alr1))%append (ftuples_alr2(i))
                   end if
                end do
             end if
          end do
       end do
     end subroutine account_for_regions_from_other_uborns
 
     subroutine setup_region_mappings (n_independent_flv, &
            alr_limits, region_to_ftuple)
        integer, intent(inout) :: n_independent_flv
        integer, intent(inout), dimension(:), allocatable :: alr_limits
        integer, intent(inout), dimension(:), allocatable :: region_to_ftuple
        integer :: i, j, i_flv
        if (any (ftuples%get_n_tuples() == 0)) &
             call msg_fatal ("Inconsistent collection of FKS pairs!")
        n_independent_flv = size (ftuples)
        alr_limits = ftuples%get_n_tuples()
        if (.not. (sum (alr_limits) == maxregions)) &
             call msg_fatal ("Too many regions!")
        j = 1
        do i_flv = 1, n_independent_flv
           do i = 1, alr_limits(i_flv)
              region_to_ftuple(j) = i
              j = j + 1
           end do
        end do
     end subroutine setup_region_mappings
 
     subroutine check_permutation (perm, flv_perm, flv_orig, i_reg)
       type(flavor_permutation_t), intent(in) :: perm
       type(flv_structure_t), intent(in) :: flv_perm, flv_orig
       integer, intent(in) :: i_reg
       type(flv_structure_t) :: flv_test
       flv_test = perm%apply (flv_orig, invert = .true.)
       if (.not. all (flv_test%flst == flv_perm%flst)) then
          print *, 'Fail at: ', i_reg
          print *, 'Original flavor structure: ', flv_orig%flst
          call perm%write ()
          print *, 'Permuted flavor: ', flv_perm%flst
          print *, 'Should be: ', flv_test%flst
          call msg_fatal ("Permutation does not reproduce original flavor!")
       end if
     end subroutine check_permutation
 
     subroutine init_regions_with_permuted_flavors ()
        type(flavor_permutation_t) :: perm_list
        type(ftuple_t), dimension(:), allocatable :: ftuple_array
        logical, dimension(:,:), allocatable :: equivalences
        integer :: i, j
        do j = 1, n_regions
           do i = 1, reg_data%n_flv_born
              if (reg_data%flv_born (i) .equiv. flv_uborn (j)) then
                 call perm_list%reset ()
                 call perm_list%init (reg_data%flv_born(i), flv_uborn(j), &
                      reg_data%n_in, reg_data%n_legs_born, .true.)
                 flv_uborn(j) = perm_list%apply (flv_uborn(j))
                 flv_alr_registered(j) = perm_list%apply (flv_alr_registered(j))
                 flst_emitter(j) = perm_list%apply (flst_emitter(j))
              end if
           end do
           call ftuples(index(j))%to_array (ftuple_array, equivalences, .false.)
           do i = 1, size (reg_data%flv_real)
              if (reg_data%flv_real(i) .equiv. flv_alr_registered(j)) then
                 call perm_list%reset ()
                 call perm_list%init (flv_alr_registered(j), reg_data%flv_real(i), &
                      reg_data%n_in, reg_data%n_legs_real, .false.)
                 if (debug_active (D_SUBTRACTION)) call check_permutation &
                      (perm_list, reg_data%flv_real(i), flv_alr_registered(j), j)
                 ftuple_array = perm_list%apply (ftuple_array)
                 call ftuple_sort_array (ftuple_array, equivalences)
              end if
           end do
           call reg_data%regions(j)%init (j, mult(j), 0, flv_alr_registered(j), &
                flv_uborn(j), reg_data%flv_born, flst_emitter(j), ftuple_array, &
                equivalences, nlo_correction_type)
           if (allocated (ftuple_array)) deallocate (ftuple_array)
           if (allocated (equivalences)) deallocate (equivalences)
        end do
     end subroutine init_regions_with_permuted_flavors
 
     subroutine assign_real_indices ()
       type(flv_structure_t) :: current_flv_real
       type(flv_structure_t), dimension(:), allocatable :: these_flv
       integer :: i_real, current_uborn_index
       integer :: i, j, this_i_real
       allocate (these_flv (size (flv_alr_registered)))
       i_real = 1
       associate (regions => reg_data%regions)
          do i = 1, reg_data%n_regions
             do j = 1, size (these_flv)
                if (.not. allocated (these_flv(j)%flst)) then
                   this_i_real = i_real
                   call these_flv(i_real)%init (flv_alr_registered(i)%flst, reg_data%n_in)
                   i_real = i_real + 1
                   exit
                else if (all (these_flv(j)%flst == flv_alr_registered(i)%flst)) then
                   this_i_real = j
                   exit
                end if
             end do
             regions(i)%real_index = this_i_real
          end do
       end associate
       deallocate (these_flv)
     end subroutine assign_real_indices
 
     subroutine write_perm_list (perm_list)
       integer, intent(in), dimension(:,:) :: perm_list
       integer :: i
       do i = 1, size (perm_list(:,1))
          write (*,'(I1,1x,I1,A)', advance = "no" ) perm_list(i,1), perm_list(i,2), '/'
       end do
       print *, ''
     end subroutine write_perm_list
 
     function check_fs_splitting (flv1, flv2, tag1, tag2) result (valid)
       logical :: valid
       integer, intent(in), dimension(2) :: flv1, flv2
       integer, intent(in) :: tag1, tag2
       if (flv1(1) + flv1(2) == 0) then
          valid = abs(flv1(1)) == abs(flv2(1)) .and. abs(flv1(2)) == abs(flv2(2))
       else
          valid = flv1(1) == flv2(1) .and. flv1(2) == flv2(2) .and. tag1 == tag2
       end if
     end function check_fs_splitting
   end subroutine region_data_init_singular_regions
 
 @ %def region_data_init_singular_regions
 @ Create an array containing all emitters and resonances of [[region_data]].
 <<fks regions: reg data: TBP>>=
   procedure :: find_emitters => region_data_find_emitters
 <<fks regions: procedures>>=
   subroutine region_data_find_emitters (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr, j, n_em, em
     integer, dimension(:), allocatable :: em_count
     allocate (em_count(reg_data%n_regions))
     em_count = -1
     n_em = 0
 
     !!!Count the number of different emitters
     do alr = 1, reg_data%n_regions
        em = reg_data%regions(alr)%emitter
        if (.not. any (em_count == em)) then
           n_em = n_em + 1
           em_count(alr) = em
        end if
     end do
 
     if (n_em < 1) call msg_fatal ("region_data_find_emitters: No emitters found!")
     reg_data%n_emitters = n_em
     allocate (reg_data%emitters (reg_data%n_emitters))
     reg_data%emitters = -1
 
     j = 1
     do alr = 1, size (reg_data%regions)
        em = reg_data%regions(alr)%emitter
        if (.not. any (reg_data%emitters == em)) then
           reg_data%emitters(j) = em
           j = j + 1
        end if
     end do
   end subroutine region_data_find_emitters
 
 @ %def region_data_find_emitters
 @
 <<fks regions: reg data: TBP>>=
   procedure :: find_resonances => region_data_find_resonances
 <<fks regions: procedures>>=
   subroutine region_data_find_resonances (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr, j, k, n_res, n_contr
     integer :: res
     integer, dimension(10) :: res_count
     type(resonance_contributors_t), dimension(10) :: contributors_count
     type(resonance_contributors_t) :: contributors
     integer :: i_res, emitter
     logical :: share_emitter
     res_count = -1
     n_res = 0; n_contr = 0
 
     !!! Count the number of different resonances
     do alr = 1, reg_data%n_regions
        select type (fks_mapping => reg_data%fks_mapping)
        type is (fks_mapping_resonances_t)
           res = fks_mapping%res_map%alr_to_i_res (alr)
           if (.not. any (res_count == res)) then
              n_res = n_res + 1
              res_count(alr) = res
           end if
        end select
     end do
 
     if (n_res > 0) allocate (reg_data%resonances (n_res))
 
     j = 1
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        do alr = 1, size (reg_data%regions)
           res = fks_mapping%res_map%alr_to_i_res (alr)
           if (.not. any (reg_data%resonances == res)) then
              reg_data%resonances(j) = res
              j = j + 1
           end if
        end do
 
        allocate (reg_data%alr_to_i_contributor (size (reg_data%regions)))
        do alr = 1, size (reg_data%regions)
           i_res = fks_mapping%res_map%alr_to_i_res (alr)
           emitter = reg_data%regions(alr)%emitter
           call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
           if (.not. share_emitter) cycle
           if (.not. any (contributors_count == contributors)) then
              n_contr = n_contr + 1
              contributors_count(alr) = contributors
           end if
           if (allocated (contributors%c)) deallocate (contributors%c)
        end do
        allocate (reg_data%alr_contributors (n_contr))
        j = 1
        do alr = 1, size (reg_data%regions)
           i_res = fks_mapping%res_map%alr_to_i_res (alr)
           emitter = reg_data%regions(alr)%emitter
           call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
           if (.not. share_emitter) cycle
           if (.not. any (reg_data%alr_contributors == contributors)) then
              reg_data%alr_contributors(j) = contributors
              reg_data%alr_to_i_contributor (alr) = j
              j = j + 1
           else
              do k = 1, size (reg_data%alr_contributors)
                 if (reg_data%alr_contributors(k) == contributors) exit
              end do
              reg_data%alr_to_i_contributor (alr) = k
           end if
           if (allocated (contributors%c)) deallocate (contributors%c)
        end do
     end select
     call reg_data%extend_ftuples (n_res)
     call reg_data%set_contributors ()
 
   end subroutine region_data_find_resonances
 
 @ %def region_data_find_resonances
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_i_phs_to_i_con => region_data_set_i_phs_to_i_con
 <<fks regions: procedures>>=
   subroutine region_data_set_i_phs_to_i_con (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr
     integer :: i_res, emitter, i_con, i_phs, i_em
     type(phs_identifier_t), dimension(:), allocatable :: phs_id_tmp
     logical :: share_emitter, phs_exist
     type(resonance_contributors_t) :: contributors
     allocate (phs_id_tmp (reg_data%n_phs))
     if (allocated (reg_data%resonances)) then
        allocate (reg_data%i_phs_to_i_con (reg_data%n_phs))
        do i_em = 1, size (reg_data%emitters)
           emitter = reg_data%emitters(i_em)
           do i_res = 1, size (reg_data%resonances)
              if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then
                 alr = find_alr (emitter, i_res)
                 if (alr == 0) call msg_fatal ("Could not find requested alpha region!")
                 i_con = reg_data%alr_to_i_contributor (alr)
                 call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
                 if (.not. share_emitter) cycle
                 call check_for_phs_identifier &
                    (phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
                 if (phs_id_tmp(i_phs)%emitter < 0) then
                    phs_id_tmp(i_phs)%emitter = emitter
                    allocate (phs_id_tmp(i_phs)%contributors (size (contributors%c)))
                    phs_id_tmp(i_phs)%contributors = contributors%c
                 end if
                 reg_data%i_phs_to_i_con (i_phs) = i_con
              end if
              if (allocated (contributors%c)) deallocate (contributors%c)
           end do
        end do
     end if
   contains
     function find_alr (emitter, i_res) result (alr)
        integer :: alr
        integer, intent(in) :: emitter, i_res
        integer :: i
        do i = 1, reg_data%n_regions
           if (reg_data%regions(i)%emitter == emitter .and. &
               reg_data%regions(i)%i_res == i_res) then
              alr = i
              return
           end if
        end do
        alr = 0
     end function find_alr
   end subroutine region_data_set_i_phs_to_i_con
 
 @ %def region_data_set_i_phs_to_i_con
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_alr_to_i_phs => region_data_set_alr_to_i_phs
 <<fks regions: procedures>>=
   subroutine region_data_set_alr_to_i_phs (reg_data, phs_identifiers, alr_to_i_phs)
     class(region_data_t), intent(inout) :: reg_data
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     integer, intent(out), dimension(:) :: alr_to_i_phs
     integer :: alr, i_phs
     integer :: emitter, i_res
     type(resonance_contributors_t) :: contributors
     logical :: share_emitter, phs_exist
     do alr = 1, reg_data%n_regions
        associate (region => reg_data%regions(alr))
           emitter = region%emitter
           i_res = region%i_res
           if (i_res /= 0) then
              call reg_data%get_contributors (i_res, emitter, &
                 contributors%c, share_emitter)
              if (.not. share_emitter) cycle
           end if
           if (allocated (contributors%c)) then
              call check_for_phs_identifier (phs_identifiers, reg_data%n_in, &
                 emitter, contributors%c, phs_exist = phs_exist, i_phs = i_phs)
           else
              call check_for_phs_identifier (phs_identifiers, reg_data%n_in, &
                 emitter, phs_exist = phs_exist, i_phs = i_phs)
           end if
           if (.not. phs_exist) &
              call msg_fatal ("phs identifiers are not set up correctly!")
           alr_to_i_phs(alr) = i_phs
        end associate
        if (allocated (contributors%c)) deallocate (contributors%c)
     end do
   end subroutine region_data_set_alr_to_i_phs
 
 @ %def region_data_set_alr_to_i_phs
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_contributors => region_data_set_contributors
 <<fks regions: procedures>>=
   subroutine region_data_set_contributors (reg_data)
      class(region_data_t), intent(inout) :: reg_data
      integer :: alr, i_res, i_reg, i_con
      integer :: i1, i2, i_em
      integer, dimension(:), allocatable :: contributors
      logical :: share_emitter
      do alr = 1, size (reg_data%regions)
         associate (sregion => reg_data%regions(alr))
            allocate (sregion%i_reg_to_i_con (sregion%nregions))
            do i_reg = 1, sregion%nregions
               call sregion%ftuples(i_reg)%get (i1, i2)
               i_em = get_emitter_index (i1, i2, reg_data%n_legs_real)
               i_res = sregion%ftuples(i_reg)%i_res
               call reg_data%get_contributors (i_res, i_em, contributors, share_emitter)
               !!! Lookup contributor index
               do i_con = 1, size (reg_data%alr_contributors)
                  if (all (reg_data%alr_contributors(i_con)%c == contributors)) then
                     sregion%i_reg_to_i_con (i_reg) = i_con
                     exit
                  end if
               end do
               deallocate (contributors)
            end do
         end associate
      end do
   contains
      function get_emitter_index (i1, i2, n) result (i_em)
        integer :: i_em
        integer, intent(in) :: i1, i2, n
        if (i1 == n) then
           i_em = i2
        else
           i_em = i1
        end if
      end function get_emitter_index
   end subroutine region_data_set_contributors
 
 @ %def region_data_set_contributors
 @ This extension of the ftuples is still too naive as it assumes that the same
 resonances are possible for all ftuples
 <<fks regions: reg data: TBP>>=
   procedure :: extend_ftuples => region_data_extend_ftuples
 <<fks regions: procedures>>=
   subroutine region_data_extend_ftuples (reg_data, n_res)
     class(region_data_t), intent(inout) :: reg_data
     integer, intent(in) :: n_res
     integer :: alr, n_reg_save
     integer :: i_reg, i_res, i_em, k
     type(ftuple_t), dimension(:), allocatable :: ftuple_save
     integer :: n_new
     do alr = 1, size (reg_data%regions)
        associate (sregion => reg_data%regions(alr))
           n_reg_save = sregion%nregions
           allocate (ftuple_save (n_reg_save))
           ftuple_save = sregion%ftuples
           n_new = count_n_new_ftuples (sregion, n_res)
           deallocate (sregion%ftuples)
           sregion%nregions = n_new
           allocate (sregion%ftuples (n_new))
           k = 1
           do i_res = 1, n_res
              do i_reg = 1, n_reg_save
                 associate (ftuple_new => sregion%ftuples(k))
                    i_em = ftuple_save(i_reg)%ireg(1)
                    if (reg_data%emitter_is_in_resonance (i_res, i_em)) then
                       call ftuple_new%set (i_em, ftuple_save(i_reg)%ireg(2))
                       ftuple_new%i_res = i_res
                       ftuple_new%splitting_type = ftuple_save(i_reg)%splitting_type
                       k = k + 1
                    end if
                 end associate
              end do
           end do
        end associate
        deallocate (ftuple_save)
     end do
   contains
     function count_n_new_ftuples (sregion, n_res) result (n_new)
       integer :: n_new
       type(singular_region_t), intent(in) :: sregion
       integer, intent(in) :: n_res
       integer :: i_reg, i_res, i_em
       n_new = 0
       do i_reg = 1, sregion%nregions
          do i_res = 1, n_res
             i_em = sregion%ftuples(i_reg)%ireg(1)
             if (reg_data%emitter_is_in_resonance (i_res, i_em)) &
                n_new = n_new + 1
          end do
       end do
     end function count_n_new_ftuples
   end subroutine region_data_extend_ftuples
 
 @ %def region_data_extend_ftuples
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_flavor_indices => region_data_get_flavor_indices
 <<fks regions: procedures>>=
   function region_data_get_flavor_indices (reg_data, born) result (i_flv)
     integer, dimension(:), allocatable :: i_flv
     class(region_data_t), intent(in) :: reg_data
     logical, intent(in) :: born
     allocate (i_flv (reg_data%n_regions))
     if (born) then
        i_flv = reg_data%regions%uborn_index
     else
        i_flv = reg_data%regions%real_index
     end if
   end function region_data_get_flavor_indices
 
 @ %def region_data_get_flavor_indices
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_matrix_element_index => region_data_get_matrix_element_index
 <<fks regions: procedures>>=
   function region_data_get_matrix_element_index (reg_data, i_reg) result (i_me)
     integer :: i_me
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_reg
     i_me = reg_data%regions(i_reg)%real_index
   end function region_data_get_matrix_element_index
 
 @ %def region_data_get_matrix_element_index
 @
 <<fks regions: reg data: TBP>>=
   procedure :: compute_number_of_phase_spaces &
      => region_data_compute_number_of_phase_spaces
 <<fks regions: procedures>>=
   subroutine region_data_compute_number_of_phase_spaces (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: i_em, i_res, i_phs
     integer :: emitter
     type(resonance_contributors_t) :: contributors
     integer, parameter :: n_max_phs = 10
     type(phs_identifier_t), dimension(n_max_phs) :: phs_id_tmp
     logical :: share_emitter, phs_exist
     if (allocated (reg_data%resonances)) then
        reg_data%n_phs = 0
        do i_em = 1, size (reg_data%emitters)
           emitter = reg_data%emitters(i_em)
           do i_res = 1, size (reg_data%resonances)
              if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then
                 call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
                 if (.not. share_emitter) cycle
                 call check_for_phs_identifier &
                    (phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
                 if (.not. phs_exist) then
                    reg_data%n_phs = reg_data%n_phs + 1
                    if (reg_data%n_phs > n_max_phs) call msg_fatal &
                       ("Buffer of phase space identifieres: Too much phase spaces!")
                    call phs_id_tmp(i_phs)%init (emitter, contributors%c)
                 end if
              end if
              if (allocated (contributors%c)) deallocate (contributors%c)
           end do
        end do
     else
        reg_data%n_phs = size (remove_duplicates_from_int_array (reg_data%emitters))
     end if
   end subroutine region_data_compute_number_of_phase_spaces
 
 @ %def region_data_compute_number_of_phase_spaces
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_phs => region_data_get_n_phs
 <<fks regions: procedures>>=
   function region_data_get_n_phs (reg_data) result (n_phs)
     integer :: n_phs
     class(region_data_t), intent(in) :: reg_data
     n_phs = reg_data%n_phs
   end function region_data_get_n_phs
 
 @ %def region_data_get_n_phs
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_splitting_info => region_data_set_splitting_info
 <<fks regions: procedures>>=
   subroutine region_data_set_splitting_info (reg_data)
      class(region_data_t), intent(inout) :: reg_data
      integer :: alr
      do alr = 1, reg_data%n_regions
         call reg_data%regions(alr)%set_splitting_info (reg_data%n_in)
      end do
    end subroutine region_data_set_splitting_info
 
 @ %def region_data_set_splitting_info
 @
 <<fks regions: reg data: TBP>>=
   procedure :: init_phs_identifiers => region_data_init_phs_identifiers
 <<fks regions: procedures>>=
   subroutine region_data_init_phs_identifiers (reg_data, phs_id)
     class(region_data_t), intent(in) :: reg_data
     type(phs_identifier_t), intent(out), dimension(:), allocatable :: phs_id
     integer :: i_em, i_res, i_phs
     integer :: emitter
     type(resonance_contributors_t) :: contributors
     logical :: share_emitter, phs_exist
     allocate (phs_id (reg_data%n_phs))
     do i_em = 1, size (reg_data%emitters)
        emitter = reg_data%emitters(i_em)
        if (allocated (reg_data%resonances)) then
           do i_res = 1, size (reg_data%resonances)
              call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
              if (.not. share_emitter) cycle
              call check_for_phs_identifier &
                 (phs_id, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
              if (.not. phs_exist) &
                 call phs_id(i_phs)%init (emitter, contributors%c)
              if (allocated (contributors%c)) deallocate (contributors%c)
           end do
        else
           call check_for_phs_identifier (phs_id, reg_data%n_in, emitter, &
              phs_exist = phs_exist, i_phs = i_phs)
           if (.not. phs_exist) call phs_id(i_phs)%init (emitter)
        end if
     end do
   end subroutine region_data_init_phs_identifiers
 
 @ %def region_data_init_phs_identifiers
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_all_ftuples => region_data_get_all_ftuples
 <<fks regions: procedures>>=
   subroutine region_data_get_all_ftuples (reg_data, ftuples)
     class(region_data_t), intent(in) :: reg_data
     type(ftuple_t), intent(inout), dimension(:), allocatable :: ftuples
     type(ftuple_t), dimension(:), allocatable :: ftuple_tmp
     integer :: i, j, alr
     !!! Can have at most n * (n-1) ftuples
     j = 0
     allocate (ftuple_tmp (reg_data%n_legs_real * (reg_data%n_legs_real - 1)))
     do i = 1, reg_data%n_regions
        associate (region => reg_data%regions(i))
           do alr = 1, region%nregions
              if (.not. any (region%ftuples(alr) == ftuple_tmp)) then
                 j = j + 1
                 ftuple_tmp(j) = region%ftuples(alr)
              end if
           end do
        end associate
     end do
     allocate (ftuples (j))
     ftuples = ftuple_tmp(1:j)
     deallocate (ftuple_tmp)
   end subroutine region_data_get_all_ftuples
 
 @ %def region_data_get_all_ftuples
 @
 <<fks regions: reg data: TBP>>=
   procedure :: write_to_file => region_data_write_to_file
 <<fks regions: procedures>>=
   subroutine region_data_write_to_file (reg_data, proc_id, latex, os_data)
      class(region_data_t), intent(inout) :: reg_data
      type(string_t), intent(in) :: proc_id
      logical, intent(in) :: latex
      type(os_data_t), intent(in) :: os_data
      type(string_t) :: filename
      integer :: u
      integer :: status
 
      if (latex) then
          filename = proc_id // "_fks_regions.tex"
      else
         filename = proc_id // "_fks_regions.out"
      end if
      u = free_unit ()
      open (u, file=char(filename), action = "write", status="replace")
      if (latex) then
         call reg_data%write_latex (u)
         close (u)
         call os_data%build_latex_file &
              (proc_id // "_fks_regions", stat_out = status)
         if (status /= 0) &
              call msg_error (char ("Failed to compile " // filename))
      else
         call reg_data%write (u)
         close (u)
      end if
   end subroutine region_data_write_to_file
 
 @ %def region_data_write_to_file
 @
 <<fks regions: reg data: TBP>>=
   procedure :: write_latex => region_data_write_latex
 <<fks regions: procedures>>=
   subroutine region_data_write_latex (reg_data, unit)
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in), optional :: unit
     integer :: i, u
     u = given_output_unit (); if (present (unit)) u = unit
     write (u, "(A)") "\documentclass{article}"
     write (u, "(A)") "\begin{document}"
     write (u, "(A)") "%FKS region data, automatically created by WHIZARD"
     write (u, "(A)") "\begin{table}"
     write (u, "(A)") "\begin{center}"
     write (u, "(A)") "\begin{tabular} {|c|c|c|c|c|c|c|c|}"
     write (u, "(A)") "\hline"
     write (u, "(A)") "$\alpha_r$ & $f_r$ & $i_r$ & $\varepsilon$ & $\varsigma$ & $\mathcal{P}_{\rm{FKS}}$ & $i_b$ & $f_b$ \\"
     write (u, "(A)") "\hline"
     do i = 1, reg_data%n_regions
        call reg_data%regions(i)%write_latex (u)
     end do
     write (u, "(A)") "\hline"
     write (u, "(A)") "\end{tabular}"
     write (u, "(A)") "\caption{List of singular regions}"
     write (u, "(A)") "\begin{description}"
     write (u, "(A)") "\item[$\alpha_r$] Index of the singular region"
     write (u, "(A)") "\item[$f_r$] Real flavor structure"
     write (u, "(A)") "\item[$i_r$] Index of the associated real flavor structure"
     write (u, "(A)") "\item[$\varepsilon$] Emitter"
     write (u, "(A)") "\item[$\varsigma$] Multiplicity" !!! The symbol used by 0908.4272 for multiplicities
     write (u, "(A)") "\item[$\mathcal{P}_{\rm{FKS}}$] The set of singular FKS-pairs"
     write (u, "(A)") "\item[$i_b$] Underlying Born index"
     write (u, "(A)") "\item[$f_b$] Underlying Born flavor structure"
     write (u, "(A)") "\end{description}"
     write (u, "(A)") "\end{center}"
     write (u, "(A)") "\end{table}"
     write (u, "(A)") "\end{document}"
   end subroutine region_data_write_latex
 
 @ %def region_data_write_latex
 @ Creates a table with information about all singular regions and
 writes it to a file.
 <<fks regions: reg data: TBP>>=
   procedure :: write => region_data_write
 <<fks regions: procedures>>=
   subroutine region_data_write (reg_data, unit)
      class(region_data_t), intent(in) :: reg_data
      integer, intent(in), optional :: unit
      integer :: j
      integer :: maxnregions, i_reg_max
      type(string_t) :: flst_title, ftuple_title
      integer :: n_res, u
      u = given_output_unit (unit); if (u < 0) return
      maxnregions = 1; i_reg_max = 1
      do j = 1, reg_data%n_regions
         if (size (reg_data%regions(j)%ftuples) > maxnregions) then
            maxnregions = reg_data%regions(j)%nregions
            i_reg_max = j
         end if
      end do
      flst_title = '(A' // flst_title_format(reg_data%n_legs_real) // ')'
      ftuple_title = '(A' // ftuple_title_format() // ')'
      write (u,'(A,1X,I4)') 'Total number of regions: ', size(reg_data%regions)
      write (u, '(A4)', advance = 'no') ' alr'
      call write_vline (u)
      write (u, char (flst_title), advance = 'no') 'flst_real'
      call write_vline (u)
      write (u, '(A6)', advance = 'no') 'i_real'
      call write_vline (u)
      write (u, '(A3)', advance = 'no') 'em'
      call write_vline (u)
      write (u, '(A3)', advance = 'no') 'mult'
      call write_vline (u)
      write (u, '(A4)', advance = 'no') 'nreg'
      call write_vline (u)
      if (allocated (reg_data%fks_mapping)) then
         select type (fks_mapping => reg_data%fks_mapping)
         type is (fks_mapping_resonances_t)
            write (u, '(A3)', advance = 'no') 'res'
            call write_vline (u)
         end select
      end if
      write (u, char (ftuple_title), advance = 'no') 'ftuples'
      call write_vline (u)
      flst_title = '(A' // flst_title_format(reg_data%n_legs_born) // ')'
      write (u, char (flst_title), advance = 'no') 'flst_born'
      call write_vline (u)
      write (u, '(A7)') 'i_born'
      do j = 1, reg_data%n_regions
         write (u, '(I4)', advance = 'no') j
         call reg_data%regions(j)%write (u, maxnregions)
      end do
      call write_separator (u)
      if (allocated (reg_data%fks_mapping)) then
         select type (fks_mapping => reg_data%fks_mapping)
         type is (fks_mapping_resonances_t)
            write (u, '(A)')
            write (u, '(A)') "The FKS regions are combined with resonance information: "
            n_res = size (fks_mapping%res_map%res_histories)
            write (u, '(A,1X,I1)') "Number of QCD resonance histories: ", n_res
            do j = 1, n_res
               write (u, '(A,1X,I1)') "i_res = ", j
               call fks_mapping%res_map%res_histories(j)%write (u)
               call write_separator (u)
            end do
         end select
      end if
 
    contains
 
      function flst_title_format (n) result (frmt)
        integer, intent(in) :: n
        type(string_t) :: frmt
        character(len=2) :: frmt_char
        write (frmt_char, '(I2)') 4 * n + 1
        frmt = var_str (frmt_char)
      end function flst_title_format
 
     function ftuple_title_format () result (frmt)
        type(string_t) :: frmt
        integer :: n_ftuple_char
        !!! An ftuple (x,x) consists of five characters. In the string, they
        !!! are separated by maxregions - 1 commas. In total these are
        !!! 5 * maxnregions + maxnregions - 1 = 6 * maxnregions - 1 characters.
        !!! The {} brackets at add two additional characters.
        n_ftuple_char = 6 * maxnregions + 1
        !!! If there are resonances, each ftuple with a resonance adds a ";x"
        !!! to the ftuple
        n_ftuple_char = n_ftuple_char + 2 * count (reg_data%regions(i_reg_max)%ftuples%i_res > 0)
        !!! Pseudo-ISR regions are denoted with a * at the end
        n_ftuple_char = n_ftuple_char + count (reg_data%regions(i_reg_max)%ftuples%pseudo_isr)
        frmt = str (n_ftuple_char)
     end function ftuple_title_format
 
   end subroutine region_data_write
 
 @ %def region_data_write
 @
 <<fks regions: procedures>>=
   subroutine write_vline (u)
     integer, intent(in) :: u
     character(len=10), parameter :: sep_format = "(1X,A2,1X)"
     write (u, sep_format, advance = 'no') '||'
   end subroutine write_vline
 
 @ %def write_vline
 @
 <<fks regions: public>>=
   public :: assignment(=)
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure region_data_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine region_data_assign (reg_data_out, reg_data_in)
     type(region_data_t), intent(out) :: reg_data_out
     type(region_data_t), intent(in) :: reg_data_in
     integer :: i
     if (allocated (reg_data_in%regions)) then
        allocate (reg_data_out%regions (size (reg_data_in%regions)))
        do i = 1, size (reg_data_in%regions)
           reg_data_out%regions(i) = reg_data_in%regions(i)
        end do
     else
        call msg_warning ("Copying region data without allocated singular regions!")
     end if
     if (allocated (reg_data_in%flv_born)) then
        allocate (reg_data_out%flv_born (size (reg_data_in%flv_born)))
        do i = 1, size (reg_data_in%flv_born)
           reg_data_out%flv_born(i) = reg_data_in%flv_born(i)
        end do
     else
        call msg_warning ("Copying region data without allocated born flavor structure!")
     end if
     if (allocated (reg_data_in%flv_real)) then
        allocate (reg_data_out%flv_real (size (reg_data_in%flv_real)))
        do i = 1, size (reg_data_in%flv_real)
           reg_data_out%flv_real(i) = reg_data_in%flv_real(i)
        end do
     else
        call msg_warning ("Copying region data without allocated real flavor structure!")
     end if
     if (allocated (reg_data_in%emitters)) then
        allocate (reg_data_out%emitters (size (reg_data_in%emitters)))
        do i = 1, size (reg_data_in%emitters)
           reg_data_out%emitters(i) = reg_data_in%emitters(i)
        end do
     else
        call msg_warning ("Copying region data without allocated emitters!")
     end if
     reg_data_out%n_regions = reg_data_in%n_regions
     reg_data_out%n_emitters = reg_data_in%n_emitters
     reg_data_out%n_flv_born = reg_data_in%n_flv_born
     reg_data_out%n_flv_real = reg_data_in%n_flv_real
     reg_data_out%n_in = reg_data_in%n_in
     reg_data_out%n_legs_born = reg_data_in%n_legs_born
     reg_data_out%n_legs_real = reg_data_in%n_legs_real
     if (allocated (reg_data_in%fks_mapping)) then
        select type (fks_mapping_in => reg_data_in%fks_mapping)
        type is (fks_mapping_default_t)
           allocate (fks_mapping_default_t :: reg_data_out%fks_mapping)
           select type (fks_mapping_out => reg_data_out%fks_mapping)
           type is (fks_mapping_default_t)
              fks_mapping_out = fks_mapping_in
           end select
        type is (fks_mapping_resonances_t)
           allocate (fks_mapping_resonances_t :: reg_data_out%fks_mapping)
           select type (fks_mapping_out => reg_data_out%fks_mapping)
           type is (fks_mapping_resonances_t)
              fks_mapping_out = fks_mapping_in
           end select
        end select
     else
        call msg_warning ("Copying region data without allocated FKS regions!")
     end if
     if (allocated (reg_data_in%resonances)) then
        allocate (reg_data_out%resonances (size (reg_data_in%resonances)))
        reg_data_out%resonances = reg_data_in%resonances
     end if
     reg_data_out%n_phs = reg_data_in%n_phs
     if (allocated (reg_data_in%alr_contributors)) then
        allocate (reg_data_out%alr_contributors (size (reg_data_in%alr_contributors)))
        reg_data_out%alr_contributors = reg_data_in%alr_contributors
     end if
     if (allocated (reg_data_in%alr_to_i_contributor)) then
        allocate (reg_data_out%alr_to_i_contributor &
           (size (reg_data_in%alr_to_i_contributor)))
        reg_data_out%alr_to_i_contributor = reg_data_in%alr_to_i_contributor
     end if
   end subroutine region_data_assign
 
 @ %def region_data_assign
 @ Returns the index of the real flavor structure an ftuple belogs to.
 <<fks regions: procedures>>=
   function region_to_real_index (list, i) result(index)
     type(ftuple_list_t), intent(in), dimension(:), allocatable :: list
     integer, intent(in) :: i
     integer, dimension(:), allocatable :: nreg
     integer :: index, j
     allocate (nreg (0))
     index = 0
     do j = 1, size (list)
        nreg = [nreg, sum (list(:j)%get_n_tuples ())]
        if (j == 1) then
           if (i <= nreg(j)) then
              index = j
              exit
           end if
        else
           if (i > nreg(j - 1) .and. i <= nreg(j)) then
              index = j
              exit
           end if
        end if
     end do
   end function region_to_real_index
 
 @ %def region_to_real_index
 @ Final state emission: Rearrange the flavor array in such a way that
 the emitted particle is last and the emitter is second last. [[i1]] is
 the index of the emitter, [[i2]] is the index of the emitted particle.
 
 Initial state emission: Just put the emitted particle to the last
 position.
 <<fks regions: procedures>>=
   function create_alr (flv1, n_in, i_em, i_rad) result(flv2)
     type(flv_structure_t), intent(in) :: flv1
     integer, intent(in) :: n_in
     integer, intent(in) :: i_em, i_rad
     type(flv_structure_t) :: flv2
     integer :: n
     n = size (flv1%flst)
     allocate (flv2%flst (n), flv2%tag (n))
     flv2%nlegs = n
     flv2%n_in = n_in
     if (i_em > n_in) then
        flv2%flst(1 : n_in) = flv1%flst(1 : n_in)
        flv2%flst(n - 1) = flv1%flst(i_em)
        flv2%flst(n) = flv1%flst(i_rad)
        flv2%tag(1 : n_in) = flv1%tag(1 : n_in)
        flv2%tag(n - 1) = flv1%tag(i_em)
        flv2%tag(n) = flv1%tag(i_rad)
        call fill_remaining_flavors (n_in, .true.)
     else
        flv2%flst(1 : n_in) = flv1%flst(1 : n_in)
        flv2%flst(n) = flv1%flst(i_rad)
        flv2%tag(1 : n_in) = flv1%tag(1 : n_in)
        flv2%tag(n) = flv1%tag(i_rad)
        call fill_remaining_flavors (n_in, .false.)
     end if
     call flv2%compute_prt_symm_fs (flv2%n_in)
   contains
 @ Order remaining particles according to their original position
 <<fks regions: procedures>>=
     subroutine fill_remaining_flavors (n_in, final_final)
       integer, intent(in) :: n_in
       logical, intent(in) :: final_final
       integer :: i, j
       logical :: check
       j = n_in + 1
       do i = n_in + 1, n
          if (final_final) then
             check = (i /= i_em .and. i /= i_rad)
          else
             check = (i /= i_rad)
          end if
          if (check) then
             flv2%flst(j) = flv1%flst(i)
             flv2%tag(j) = flv1%tag(i)
             j = j + 1
          end if
       end do
     end subroutine fill_remaining_flavors
   end function create_alr
 
 @ %def create_alr
 @
 <<fks regions: reg data: TBP>>=
   procedure :: has_pseudo_isr => region_data_has_pseudo_isr
 <<fks regions: procedures>>=
   function region_data_has_pseudo_isr (reg_data) result (val)
     logical :: val
     class(region_data_t), intent(in) :: reg_data
     val = any (reg_data%regions%pseudo_isr)
   end function region_data_has_pseudo_isr
 
 @ %def region_data_has_pseudo_isr
 @ Performs consistency checks on [[region_data]]. Up to now only
 checks that no [[ftuple]] appears more than once.
 <<fks regions: reg data: TBP>>=
   procedure :: check_consistency => region_data_check_consistency
 <<fks regions: procedures>>=
   subroutine region_data_check_consistency (reg_data, fail_fatal, unit)
     class(region_data_t), intent(in) :: reg_data
     logical, intent(in) :: fail_fatal
     integer, intent(in), optional :: unit
     integer :: u
     integer :: i_reg, alr
     integer :: i1, f1, f2
     logical :: undefined_ftuples, same_ftuple_indices, valid_splitting
     logical, dimension(4) :: no_fail
     u = given_output_unit(unit); if (u < 0) return
     no_fail = .true.
     call msg_message ("Check that no negative ftuple indices occur", unit = u)
     do i_reg = 1, reg_data%n_regions
        if (any (reg_data%regions(i_reg)%ftuples%has_negative_elements ())) then
           !!! This error is so severe that we stop immediately
           call msg_fatal ("Negative ftuple indices!")
        end if
     end do
     call msg_message ("Success!", unit = u)
     call msg_message ("Check that there is no ftuple with identical elements", unit = u)
     do i_reg = 1, reg_data%n_regions
        if (any (reg_data%regions(i_reg)%ftuples%has_identical_elements ())) then
           !!! This error is so severe that we stop immediately
           call msg_fatal ("Identical ftuple indices!")
        end if
     end do
     call msg_message ("Success!", unit = u)
     call msg_message ("Check that there are no duplicate ftuples in a region", unit = u)
     do i_reg = 1, reg_data%n_regions
        if (reg_data%regions(i_reg)%has_identical_ftuples ()) then
           if (no_fail(1)) then
              call msg_error ("FAIL: ", unit = u)
              no_fail(1) = .false.
           end if
           write (u, '(A,1x,I3)') 'i_reg:', i_reg
        end if
     end do
     if (no_fail(1)) call msg_message ("Success!", unit = u)
     call msg_message ("Check that ftuples add up to a valid splitting", unit = u)
     do i_reg = 1, reg_data%n_regions
        do alr = 1, reg_data%regions(i_reg)%nregions
           associate (region => reg_data%regions(i_reg))
              i1 = region%ftuples(alr)%ireg(1)
              if (i1 == 0) i1 = 1 !!! Gluon emission from both initial-state particles
              f1 = region%flst_real%flst(i1)
              f2 = region%flst_real%flst(region%ftuples(alr)%ireg(2))
              ! Flip PDG sign of IS fermions to allow a q -> g q splitting
              ! in which the ftuple has the flavors (q,q).
              if (i1 <= reg_data%n_in .and. is_fermion(f1)) then
                 f1 = -f1
              end if
              valid_splitting = f1 + f2 == 0 &
                   .or. (is_gluon(f1) .and. is_gluon(f2)) &
                   .or. (is_massive_vector(f1) .and. is_photon(f2)) &
                   .or. is_fermion_vector_splitting (f1, f2)
              if (.not. valid_splitting) then
                 if (no_fail(2)) then
                    call msg_error ("FAIL: ", unit = u)
                    no_fail(2) = .false.
                 end if
                 write (u, '(A,1x,I3)') 'i_reg:', i_reg
                 exit
              end if
           end associate
        end do
     end do
     if (no_fail(2)) call msg_message ("Success!", unit = u)
     call msg_message ("Check that at least one ftuple contains the emitter", unit = u)
     do i_reg = 1, reg_data%n_regions
        associate (region => reg_data%regions(i_reg))
           if (.not. any (region%emitter == region%ftuples%ireg(1))) then
              if (no_fail(3)) then
                 call msg_error ("FAIL: ", unit = u)
                 no_fail(3) = .false.
              end if
              write (u, '(A,1x,I3)') 'i_reg:', i_reg
           end if
        end associate
     end do
     if (no_fail(3)) call msg_message ("Success!", unit = u)
     call msg_message ("Check that each region has at least one ftuple &
          &with index n + 1", unit = u)
     do i_reg = 1, reg_data%n_regions
        if (.not. any (reg_data%regions(i_reg)%ftuples%ireg(2) == reg_data%n_legs_real)) then
           if (no_fail(4)) then
              call msg_error ("FAIL: ", unit = u)
              no_fail(4) = .false.
           end if
           write (u, '(A,1x,I3)') 'i_reg:', i_reg
        end if
     end do
     if (no_fail(4)) call msg_message ("Success!", unit = u)
     if (.not. all (no_fail)) &
          call abort_with_message ("Stop due to inconsistent region data!")
 
   contains
     subroutine abort_with_message (msg)
       character(len=*), intent(in) :: msg
       if (fail_fatal) then
          call msg_fatal (msg)
       else
          call msg_error (msg, unit = u)
       end if
     end subroutine abort_with_message
 
     function is_fermion_vector_splitting (pdg_1, pdg_2) result (value)
       logical :: value
       integer, intent(in) :: pdg_1, pdg_2
       value = (is_fermion (pdg_1) .and. is_massless_vector (pdg_2)) .or. &
            (is_fermion (pdg_2) .and. is_massless_vector (pdg_1))
     end function
   end subroutine region_data_check_consistency
 
 @ %def region_data_check_consistency
 @
 <<fks regions: reg data: TBP>>=
   procedure :: requires_spin_correlations => region_data_requires_spin_correlations
 <<fks regions: procedures>>=
   function region_data_requires_spin_correlations (reg_data) result (val)
     class(region_data_t), intent(in) :: reg_data
     logical :: val
     integer :: alr
     val = .false.
     do alr = 1, reg_data%n_regions
        val = reg_data%regions(alr)%sc_required
        if (val) return
     end do
   end function region_data_requires_spin_correlations
 
 @ %def region_data_requires_spin_correlations
 @ We have to apply the symmetry factor for identical particles of the
 real flavor structure to the born squared matrix element. The corresponding
 factor from the born flavor structure has to be cancelled.
 <<fks regions: reg data: TBP>>=
   procedure :: born_to_real_symm_factor_fs => region_data_born_to_real_symm_factor_fs
 <<fks regions: procedures>>=
   function region_data_born_to_real_symm_factor_fs (reg_data, alr) result (factor)
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: alr
     real(default) :: factor
     associate (flv_real => reg_data%regions(alr)%flst_real, &
             flv_uborn => reg_data%regions(alr)%flst_uborn)
        factor = flv_real%prt_symm_fs / flv_uborn%prt_symm_fs
     end associate
   end function region_data_born_to_real_symm_factor_fs
 
 @ %def region_data_born_to_real_symm_factor_fs
 @
 <<fks regions: reg data: TBP>>=
   procedure :: final => region_data_final
 <<fks regions: procedures>>=
   subroutine region_data_final (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     if (allocated (reg_data%regions)) deallocate (reg_data%regions)
     if (allocated (reg_data%flv_born)) deallocate (reg_data%flv_born)
     if (allocated (reg_data%flv_real)) deallocate (reg_data%flv_real)
     if (allocated (reg_data%emitters)) deallocate (reg_data%emitters)
     if (allocated (reg_data%fks_mapping)) deallocate (reg_data%fks_mapping)
     if (allocated (reg_data%resonances)) deallocate (reg_data%resonances)
     if (allocated (reg_data%alr_contributors)) deallocate (reg_data%alr_contributors)
     if (allocated (reg_data%alr_to_i_contributor)) deallocate (reg_data%alr_to_i_contributor)
   end subroutine region_data_final
 
 @ %def region_data_final
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_dij), deferred :: dij
 <<fks regions: interfaces>>=
   abstract interface
     function fks_mapping_dij (map, p, i, j, i_con) result (d)
       import
       real(default) :: d
       class(fks_mapping_t), intent(in) :: map
       type(vector4_t), intent(in), dimension(:) :: p
       integer, intent(in) :: i, j
       integer, intent(in), optional :: i_con
     end function fks_mapping_dij
   end interface
 
 @ %def fks_mapping_dij
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_compute_sumdij), deferred :: compute_sumdij
 <<fks regions: interfaces>>=
   abstract interface
     subroutine fks_mapping_compute_sumdij (map, sregion, p_real)
       import
       class(fks_mapping_t), intent(inout) :: map
       type(singular_region_t), intent(in) :: sregion
       type(vector4_t), intent(in), dimension(:) :: p_real
     end subroutine fks_mapping_compute_sumdij
   end interface
 
 @ %def fks_mapping_compute_sumdij
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_svalue), deferred :: svalue
 <<fks regions: interfaces>>=
   abstract interface
     function fks_mapping_svalue (map, p, i, j, i_res) result (value)
       import
       real(default) :: value
       class(fks_mapping_t), intent(in) :: map
       type(vector4_t), intent(in), dimension(:) :: p
       integer, intent(in) :: i, j
       integer, intent(in), optional :: i_res
     end function fks_mapping_svalue
   end interface
 
 @ %def fks_mapping_svalue
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_dij_soft), deferred :: dij_soft
 <<fks regions: interfaces>>=
   abstract interface
     function fks_mapping_dij_soft (map, p_born, p_soft, em, i_con) result (d)
       import
       real(default) :: d
       class(fks_mapping_t), intent(in) :: map
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(in) :: p_soft
       integer, intent(in) :: em
       integer, intent(in), optional :: i_con
     end function fks_mapping_dij_soft
   end interface
 
 @ %def fks_mapping_dij_soft
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_compute_sumdij_soft), deferred :: compute_sumdij_soft
 <<fks regions: interfaces>>=
   abstract interface
     subroutine fks_mapping_compute_sumdij_soft (map, sregion, p_born, p_soft)
       import
       class(fks_mapping_t), intent(inout) :: map
       type(singular_region_t), intent(in) :: sregion
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(in) :: p_soft
     end subroutine fks_mapping_compute_sumdij_soft
   end interface
 @ %def fks_mapping_compute_sumdij_soft
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_svalue_soft), deferred :: svalue_soft
 <<fks regions: interfaces>>=
   abstract interface
     function fks_mapping_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
       import
       real(default) :: value
       class(fks_mapping_t), intent(in) :: map
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(in) :: p_soft
       integer, intent(in) :: em
       integer, intent(in), optional :: i_res
     end function fks_mapping_svalue_soft
   end interface
 
 @ %def fks_mapping_svalue_soft
 @
 <<fks regions: fks mapping default: TBP>>=
   procedure :: set_parameter => fks_mapping_default_set_parameter
 <<fks regions: procedures>>=
   subroutine fks_mapping_default_set_parameter (map, n_in, dij_exp1, dij_exp2)
     class(fks_mapping_default_t), intent(inout) :: map
     integer, intent(in) :: n_in
     real(default), intent(in) :: dij_exp1, dij_exp2
     map%n_in = n_in
     map%exp_1 = dij_exp1
     map%exp_2 = dij_exp2
   end subroutine fks_mapping_default_set_parameter
 
 @ %def fks_mapping_default_set_parameter
 @ Computes the $d_{ij}$-quantities defined als follows:
 \begin{align*}
   d_{0i} &= \left[E_i^2\left(1-y_i\right)\right]^{p_2}\\,
   d_{1i} &= \left[2E_i^2\left(1-y_i\right)\right]^{p_2}\\,
   d_{2i} &= \left[2E_i^2\left(1+y_i\right)\right]^{p_2}\\,
 \end{align*}
 for initial state regions and
 \begin{align*}
   d_{ij} = \left[2(k_i \cdot k_j) \frac{E_i E_j}{(E_i+E_j)^2}\right]^{p_1}
 \end{align*}
 for final state regions, c.f. [1002.2581, Eq. 4.23f].
 The exponents $p_1$ and $p_2$ can be used for
 tuning the efficiency of the mapping and are set to $1$ per default.
 <<fks regions: fks mapping default: TBP>>=
   procedure :: dij => fks_mapping_default_dij
 <<fks regions: procedures>>=
   function fks_mapping_default_dij (map, p, i, j, i_con) result (d)
     real(default) :: d
     class(fks_mapping_default_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: i, j
     integer, intent(in), optional :: i_con
     d = zero
     if (map%pseudo_isr) then
        d = dij_threshold_gluon_from_top (i, j, p, map%exp_1)
     else if (i > map%n_in .and. j > map%n_in) then
        d = dij_fsr (p(i), p(j), map%exp_1)
     else
        d = dij_isr (map%n_in, i, j, p, map%exp_2)
     end if
   contains
 
     function dij_fsr (p1, p2, expo) result (d_ij)
       real(default) :: d_ij
       type(vector4_t), intent(in) :: p1, p2
       real(default), intent(in) :: expo
       real(default) :: E1, E2
       E1 = p1%p(0); E2 = p2%p(0)
       d_ij = (two * p1 * p2 * E1 * E2 / (E1 + E2)**2)**expo
     end function dij_fsr
 
     function dij_threshold_gluon_from_top (i, j, p, expo) result (d_ij)
       real(default) :: d_ij
       integer, intent(in) :: i, j
       type(vector4_t), intent(in), dimension(:) :: p
       real(default), intent(in) :: expo
       type(vector4_t) :: p_top
       if (i == THR_POS_B) then
          p_top = p(THR_POS_WP) + p(THR_POS_B)
       else
          p_top = p(THR_POS_WM) + p(THR_POS_BBAR)
       end if
       d_ij = dij_fsr (p_top, p(j), expo)
     end function dij_threshold_gluon_from_top
 
     function dij_isr (n_in, i, j, p, expo) result (d_ij)
       real(default) :: d_ij
       integer, intent(in) :: n_in, i, j
       type(vector4_t), intent(in), dimension(:) :: p
       real(default), intent(in) :: expo
       real(default) :: E, y
       select case (n_in)
       case (1)
          call get_emitter_variables (1, i, j, p, E, y)
          d_ij = (E**2 * (one - y**2))**expo
       case (2)
          if ((i == 0 .and. j > 2) .or. (j == 0 .and. i > 2)) then
             call get_emitter_variables (0, i, j, p, E, y)
             d_ij = (E**2 * (one - y**2))**expo
          else if ((i == 1 .and. j > 2) .or. (j == 1 .and. i > 2)) then
             call get_emitter_variables (1, i, j, p, E, y)
             d_ij = (two * E**2 * (one - y))**expo
          else if ((i == 2 .and. j > 2) .or. (j == 2 .and. i > 2)) then
             call get_emitter_variables (2, i, j, p, E, y)
             d_ij = (two * E**2 * (one + y))**expo
          end if
       end select
     end function dij_isr
 
     subroutine get_emitter_variables (i_check, i, j, p, E, y)
        integer, intent(in) :: i_check, i, j
        type(vector4_t), intent(in), dimension(:) :: p
        real(default), intent(out) :: E, y
        if (j == i_check) then
            E = energy (p(i))
            y = polar_angle_ct (p(i))
        else
            E = energy (p(j))
            y = polar_angle_ct(p(j))
        end if
     end subroutine get_emitter_variables
 
   end function fks_mapping_default_dij
 
 @  %def fks_mapping_default_dij
 @ Computes the quantity
 \begin{equation*}
   \mathcal{D} = \sum_k \frac{1}{d_{0k}} + \sum_{kl} \frac{1}{d_{kl}}.
 \end{equation*}
 where the sum goes over all ftuples of a single singular region.
 <<fks regions: fks mapping default: TBP>>=
   procedure :: compute_sumdij => fks_mapping_default_compute_sumdij
 <<fks regions: procedures>>=
   subroutine fks_mapping_default_compute_sumdij (map, sregion, p_real)
     class(fks_mapping_default_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p_real
     real(default) :: d
     integer :: i_ftuple, i, j
 
     associate (ftuples => sregion%ftuples)
       d = zero
       do i_ftuple = 1, sregion%nregions
          call ftuples(i_ftuple)%get (i, j)
          map%pseudo_isr = ftuples(i_ftuple)%pseudo_isr
          d = d + one / map%dij (p_real, i, j)
       end do
     end associate
     map%sumdij = d
   end subroutine fks_mapping_default_compute_sumdij
 
 @ %def fks_mapping_default_compute_sumdij
 @ Computes
 \begin{equation*}
   S_i = \frac{1}{\mathcal{D} d_{0i}}
 \end{equation*}
 or
 \begin{equation*}
   S_{ij} = \frac{1}{\mathcal{D} d_{ij}},
 \end{equation*}
 respectively.
 <<fks regions: fks mapping default: TBP>>=
   procedure :: svalue => fks_mapping_default_svalue
 <<fks regions: procedures>>=
   function fks_mapping_default_svalue (map, p, i, j, i_res) result (value)
     real(default) :: value
     class(fks_mapping_default_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: i, j
     integer, intent(in), optional :: i_res
     value = one / (map%dij (p, i, j) * map%sumdij)
   end function fks_mapping_default_svalue
 
 @ %def fks_mapping_default_svalue
 @ In the soft limit, our treatment of the divergencies requires a
 modification of the mapping functions. Recall that there, the ratios of
 the $d$-functions must approach either $1$ or $0$. This means
 \begin{equation*}
   \frac{d_{lm}}{d_{0m}} = \frac{(2k_l \cdot k_m) \left[E_lE_m /(E_l + E_m)^2\right]}{E_m^2 (1-y^2)}
     \overset {k_m = E_m \hat{k}} {=} \frac{E_l E_m^2}{(E_l + E_m)^2} \frac{2k_l \cdot \hat{k}}{E_m^2 (1-y^2)}
     \overset {E_m \to 0}{=} \frac{2k_l \cdot \hat{k}}{E_l}{(1-y^2)},
 \end{equation*}
 where we have written the gluon momentum in terms of the soft momentum
 $\hat{k}$. In the same limit
 \begin{equation*}
   \frac{d_{lm}}{d_{nm}} = \frac{k_l \cdot \hat{k}}{k_n \cdot \hat{k}} \frac{E_n}{E_l}.
 \end{equation*}
 From these equations we can deduce the soft limit of $d$:
 \begin{align*}
   d_0^{\rm{soft}} &= 1 - y^2,\\
   d_1^{\rm{soft}} &= 2(1-y),\\
   d_2^{\rm{soft}} &= 2(1+y),\\
   d_i^{\rm{soft}} &= \frac{2 k_i \cdot \hat{k}}{E_i}.
 \end{align*}
 <<fks regions: fks mapping default: TBP>>=
   procedure :: dij_soft => fks_mapping_default_dij_soft
 <<fks regions: procedures>>=
   function fks_mapping_default_dij_soft (map, p_born, p_soft, em, i_con) result (d)
     real(default) :: d
     class(fks_mapping_default_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     integer, intent(in) :: em
     integer, intent(in), optional :: i_con
     if (map%pseudo_isr) then
        d = dij_soft_threshold_gluon_from_top (em, p_born, p_soft, map%exp_1)
     else if (em <= map%n_in) then
        d = dij_soft_isr (map%n_in, p_soft, map%exp_2)
     else
        d = dij_soft_fsr (p_born(em), p_soft, map%exp_1)
     end if
   contains
 
     function dij_soft_threshold_gluon_from_top (em, p_born, p_soft, expo) result (dij_soft)
       real(default) :: dij_soft
       integer, intent(in) :: em
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(in) :: p_soft
       real(default), intent(in) :: expo
       type(vector4_t) :: p_top
       if (em == THR_POS_B) then
          p_top = p_born(THR_POS_WP) + p_born(THR_POS_B)
       else
          p_top = p_born(THR_POS_WM) + p_born(THR_POS_BBAR)
       end if
       dij_soft = dij_soft_fsr (p_top, p_soft, expo)
     end function dij_soft_threshold_gluon_from_top
 
     function dij_soft_fsr (p_em, p_soft, expo) result (dij_soft)
       real(default) :: dij_soft
       type(vector4_t), intent(in) :: p_em, p_soft
       real(default), intent(in) :: expo
       dij_soft = (two * p_em * p_soft / p_em%p(0))**expo
     end function dij_soft_fsr
 
     function dij_soft_isr (n_in, p_soft, expo) result (dij_soft)
        real(default) :: dij_soft
        integer, intent(in) :: n_in
        type(vector4_t), intent(in) :: p_soft
        real(default), intent(in) :: expo
        real(default) :: y
        y = polar_angle_ct (p_soft)
        select case (n_in)
        case (1)
           dij_soft = one - y**2
        case (2)
           select case (em)
           case (0)
              dij_soft = one - y**2
           case (1)
              dij_soft = two * (one - y)
           case (2)
              dij_soft = two * (one + y)
           case default
              dij_soft = zero
              call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2")
           end select
        case default
           dij_soft = zero
           call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2")
        end select
        dij_soft = dij_soft**expo
     end function dij_soft_isr
   end function fks_mapping_default_dij_soft
 
 @ %def fks_mapping_default_dij_soft
 @ Computes the sum of all soft [[dij]]s required to normalize the soft S functions
 [[s_alpha_soft]] similar to [[fks_mapping_default_compute_sumdij]].
 In the soft limit however, we need to skip all ftuples $(i,j)$ in which $j$ does
 not correspond to the emitted particle because those $d_{ij}$s are finite and thus
 their contribution to the soft S function vanishes in the limit of soft radiation.
 Technically, they would not vanish if computed here because the fixed [[p_soft]]
 at this point would not fit their actual emitter.
 <<fks regions: fks mapping default: TBP>>=
   procedure :: compute_sumdij_soft => fks_mapping_default_compute_sumdij_soft
 <<fks regions: procedures>>=
   subroutine fks_mapping_default_compute_sumdij_soft (map, sregion, p_born, p_soft)
     class(fks_mapping_default_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     real(default) :: d
     integer :: i_ftuple, i, j
     integer :: nlegs
     d = zero
     nlegs = size (sregion%flst_real%flst)
     associate (ftuples => sregion%ftuples)
       do i_ftuple = 1, sregion%nregions
          call ftuples(i_ftuple)%get (i ,j)
          if (j == nlegs) then
             map%pseudo_isr = ftuples(i_ftuple)%pseudo_isr
             d = d + one / map%dij_soft (p_born, p_soft, i)
          end if
       end do
     end associate
     map%sumdij_soft = d
   end subroutine fks_mapping_default_compute_sumdij_soft
 
 @ %def fks_mapping_default_compute_sumdij_soft
 @
 <<fks regions: fks mapping default: TBP>>=
   procedure :: svalue_soft => fks_mapping_default_svalue_soft
 <<fks regions: procedures>>=
   function fks_mapping_default_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
     real(default) :: value
     class(fks_mapping_default_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     integer, intent(in) :: em
     integer, intent(in), optional :: i_res
     value = one / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em))
   end function fks_mapping_default_svalue_soft
 
 @ %def fks_mapping_default_svalue_soft
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure fks_mapping_default_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine fks_mapping_default_assign (fks_map_out, fks_map_in)
     type(fks_mapping_default_t), intent(out) :: fks_map_out
     type(fks_mapping_default_t), intent(in) :: fks_map_in
     fks_map_out%exp_1 = fks_map_in%exp_1
     fks_map_out%exp_2 = fks_map_in%exp_2
     fks_map_out%n_in = fks_map_in%n_in
   end subroutine fks_mapping_default_assign
 
 @ %def fks_mapping_default_assign
 @ The $d_{ij,k}$-functions for the resonance mapping are basically the same
 as in the default case, but the kinematical values here must be evaluated
 in the resonance frame of reference. The energy of parton $i$ in a given
 resonance frame with momentum $p_{res}$ is
 \begin{equation*}
    E_i = \frac{p_i^0 \cdot p_{res}}{m_{res}}.
 \end{equation*}
 However, since the expressions only depend on ratios of four-momenta, we
 leave out the denominator because it will cancel out anyway.
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: dij => fks_mapping_resonances_dij
 <<fks regions: procedures>>=
   function fks_mapping_resonances_dij (map, p, i, j, i_con) result (d)
     real(default) :: d
     class(fks_mapping_resonances_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: i, j
     integer, intent(in), optional :: i_con
     real(default) :: E1, E2
     integer :: ii_con
     if (present (i_con)) then
        ii_con = i_con
     else
        call msg_fatal ("Resonance mappings require resonance index as input!")
     end if
     d = 0
     if (i /= j) then
        if (i > 2 .and. j > 2) then
           associate (p_res => map%res_map%p_res (ii_con))
              E1 = p(i) * p_res
              E2 = p(j) * p_res
              d = two * p(i) * p(j) * E1 * E2 / (E1 + E2)**2
           end associate
        else
           call msg_fatal ("Resonance mappings are not implemented for ISR")
        end if
     end if
   end function fks_mapping_resonances_dij
 
 @ %def fks_mapping_resonances_dij
 @ Computes
 \begin{equation*}
   S_\alpha = \frac{P^{f_r(\alpha)}d^{-1}(\alpha)}
      {\sum_{f_r' \in T(F_r(\alpha))}P^{f_r'}\sum_{\alpha' \in Sr(f_r')}d^{-1}(\alpha)}.
 \end{equation*}
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: compute_sumdij => fks_mapping_resonances_compute_sumdij
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_compute_sumdij (map, sregion, p_real)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p_real
     real(default) :: d, pfr
     integer :: i_res, i_reg, i, j, i_con
     integer :: nlegreal
 
     nlegreal = size (p_real)
     d = zero
     do i_reg = 1, sregion%nregions
        associate (ftuple => sregion%ftuples(i_reg))
           call ftuple%get (i, j)
           i_res = ftuple%i_res
        end associate
        pfr = map%res_map%get_resonance_value (i_res, p_real, nlegreal)
        i_con = sregion%i_reg_to_i_con (i_reg)
        d = d + pfr / map%dij (p_real, i, j, i_con)
     end do
     map%sumdij = d
   end subroutine fks_mapping_resonances_compute_sumdij
 
 @ %def fks_mapping_resonances_compute_sumdij
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: svalue => fks_mapping_resonances_svalue
 <<fks regions: procedures>>=
   function fks_mapping_resonances_svalue (map, p, i, j, i_res) result (value)
     real(default) :: value
     class(fks_mapping_resonances_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: i, j
     integer, intent(in), optional :: i_res
     real(default) :: pfr
     integer :: i_gluon
     i_gluon = size (p)
     pfr = map%res_map%get_resonance_value (i_res, p, i_gluon)
     value = pfr / (map%dij (p, i, j, map%i_con) * map%sumdij)
   end function fks_mapping_resonances_svalue
 
 @ %def fks_mapping_resonances_svalue
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: get_resonance_weight => fks_mapping_resonances_get_resonance_weight
 <<fks regions: procedures>>=
   function fks_mapping_resonances_get_resonance_weight (map, alr, p) result (pfr)
     real(default) :: pfr
     class(fks_mapping_resonances_t), intent(in) :: map
     integer, intent(in) :: alr
     type(vector4_t), intent(in), dimension(:) :: p
     pfr = map%res_map%get_weight (alr, p)
   end function fks_mapping_resonances_get_resonance_weight
 
 @ %def fks_mapping_resonances_get_resonance_weight
 @ As above, the soft limit of $d_{ij,k}$ must be computed in the resonance frame of
 reference.
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: dij_soft => fks_mapping_resonances_dij_soft
 <<fks regions: procedures>>=
   function fks_mapping_resonances_dij_soft (map, p_born, p_soft, em, i_con) result (d)
      real(default) :: d
      class(fks_mapping_resonances_t), intent(in) :: map
      type(vector4_t), intent(in), dimension(:) :: p_born
      type(vector4_t), intent(in) :: p_soft
      integer, intent(in) :: em
      integer, intent(in), optional :: i_con
      real(default) :: E1, E2
      integer :: ii_con
      type(vector4_t) :: pb
      if (present (i_con)) then
         ii_con = i_con
      else
         call msg_fatal ("fks_mapping_resonances requires resonance index")
      end if
      associate (p_res => map%res_map%p_res(ii_con))
         pb = p_born(em)
         E1 = pb * p_res
         E2 = p_soft * p_res
         d = two * pb * p_soft * E1 * E2 / E1**2
      end associate
   end function fks_mapping_resonances_dij_soft
 
 @ %def fks_mapping_resonances_dij_soft
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: compute_sumdij_soft => fks_mapping_resonances_compute_sumdij_soft
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_compute_sumdij_soft (map, sregion, p_born, p_soft)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     real(default) :: d
     real(default) :: pfr
     integer :: i_res, i, j, i_reg, i_con
     integer :: nlegs
 
     d = zero
     nlegs = size (sregion%flst_real%flst)
     do i_reg = 1, sregion%nregions
        associate (ftuple => sregion%ftuples(i_reg))
           call ftuple%get(i, j)
           i_res = ftuple%i_res
        end associate
        pfr = map%res_map%get_resonance_value (i_res, p_born)
        i_con = sregion%i_reg_to_i_con (i_reg)
        if (j == nlegs) d = d + pfr / map%dij_soft (p_born, p_soft, i, i_con)
     end do
     map%sumdij_soft = d
   end subroutine fks_mapping_resonances_compute_sumdij_soft
 
 @ %def fks_mapping_resonances_compute_sumdij_soft
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: svalue_soft => fks_mapping_resonances_svalue_soft
 <<fks regions: procedures>>=
   function fks_mapping_resonances_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
     real(default) :: value
     class(fks_mapping_resonances_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     integer, intent(in) :: em
     integer, intent(in), optional :: i_res
     real(default) :: pfr
     pfr = map%res_map%get_resonance_value (i_res, p_born)
     value = pfr / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em, map%i_con))
   end function fks_mapping_resonances_svalue_soft
 
 @ %def fks_mapping_resonances_svalue_soft
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: set_resonance_momentum => fks_mapping_resonances_set_resonance_momentum
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_set_resonance_momentum (map, p)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(vector4_t), intent(in) :: p
     map%res_map%p_res = p
   end subroutine fks_mapping_resonances_set_resonance_momentum
 
 @ %def fks_mapping_resonances_set_resonance_momentum
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: set_resonance_momenta => fks_mapping_resonances_set_resonance_momenta
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_set_resonance_momenta (map, p)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     map%res_map%p_res = p
   end subroutine fks_mapping_resonances_set_resonance_momenta
 
 @ %def fks_mapping_resonances_set_resonance_momenta
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure fks_mapping_resonances_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_assign (fks_map_out, fks_map_in)
     type(fks_mapping_resonances_t), intent(out) :: fks_map_out
     type(fks_mapping_resonances_t), intent(in) :: fks_map_in
     fks_map_out%exp_1 = fks_map_in%exp_1
     fks_map_out%exp_2 = fks_map_in%exp_2
     fks_map_out%res_map = fks_map_in%res_map
   end subroutine fks_mapping_resonances_assign
 
 @ %def fks_mapping_resonances_assign
 @
 <<fks regions: public>>=
   public :: create_resonance_histories_for_threshold
 <<fks regions: procedures>>=
   function create_resonance_histories_for_threshold () result (res_history)
     type(resonance_history_t) :: res_history
     res_history%n_resonances = 2
     allocate (res_history%resonances (2))
     allocate (res_history%resonances(1)%contributors%c(2))
     allocate (res_history%resonances(2)%contributors%c(2))
     res_history%resonances(1)%contributors%c = [THR_POS_WP, THR_POS_B]
     res_history%resonances(2)%contributors%c = [THR_POS_WM, THR_POS_BBAR]
   end function create_resonance_histories_for_threshold
 
 @ %def create_resonance_histories_for_threshold
 @
 <<fks regions: public>>=
   public :: setup_region_data_for_test
 <<fks regions: procedures>>=
   subroutine setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, nlo_corr_type)
     integer, intent(in) :: n_in
     integer, intent(in), dimension(:,:) :: flv_born, flv_real
     type(string_t), intent(in) :: nlo_corr_type
     type(region_data_t), intent(out) :: reg_data
     type(model_t), pointer :: test_model => null ()
     call create_test_model (var_str ("SM"), test_model)
     call test_model%set_real (var_str ("me"), 0._default)
     call test_model%set_real (var_str ("mmu"), 0._default)
     call test_model%set_real (var_str ("mtau"), 0._default)
     call test_model%set_real (var_str ("ms"), 0._default)
     call test_model%set_real (var_str ("mc"), 0._default)
     call test_model%set_real (var_str ("mb"), 0._default)
     call reg_data%init (n_in, test_model, flv_born, flv_real, nlo_corr_type)
   end subroutine setup_region_data_for_test
 
 @ %def setup_region_data_for_test
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \subsection{Unit tests}
 \clearpage
 <<[[fks_regions_ut.f90]]>>=
 <<File header>>
 
 module fks_regions_ut
   use unit_tests
   use fks_regions_uti
 
 <<Standard module head>>
 
 <<fks regions: public test>>
 
 contains
 
 <<fks regions: test driver>>
 
 end module fks_regions_ut
 @ %def fks_regions_ut
 @
 <<[[fks_regions_uti.f90]]>>=
 <<File header>>
 
 module fks_regions_uti
 
 <<Use strings>>
   use format_utils, only: write_separator
   use os_interface
   use models
 
   use fks_regions
 
 <<Standard module head>>
 
 <<fks regions: test declarations>>
 
 contains
 
 <<fks regions: tests>>
 
 end module fks_regions_uti
 @ %def fks_regions_uti
 @
 <<fks regions: public test>>=
   public :: fks_regions_test
 <<fks regions: test driver>>=
   subroutine fks_regions_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
     call test(fks_regions_1, "fks_regions_1", &
          "Test flavor structure utilities", u, results)
     call test(fks_regions_2, "fks_regions_2", &
          "Test singular regions for final-state radiation for n = 2", &
          u, results)
     call test(fks_regions_3, "fks_regions_3", &
          "Test singular regions for final-state radiation for n = 3", &
          u, results)
     call test(fks_regions_4, "fks_regions_4", &
          "Test singular regions for final-state radiation for n = 4", &
          u, results)
     call test(fks_regions_5, "fks_regions_5", &
          "Test singular regions for final-state radiation for n = 5", &
          u, results)
     call test(fks_regions_6, "fks_regions_6", &
          "Test singular regions for initial-state radiation", &
          u, results)
     call test(fks_regions_7, "fks_regions_7", &
          "Check Latex output", u, results)
     call test(fks_regions_8, "fks_regions_8", &
          "Test singular regions for initial-state photon contributions", &
          u, results)
   end subroutine fks_regions_test
 
 @ %def fks_regions_test
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_1
 <<fks regions: tests>>=
   subroutine fks_regions_1 (u)
     integer, intent(in) :: u
     type(flv_structure_t) :: flv_born, flv_real
     type(model_t), pointer :: test_model => null ()
     write (u, "(A)") "* Test output: fks_regions_1"
     write (u, "(A)") "* Purpose: Test utilities of flavor structure manipulation"
     write (u, "(A)")
 
     call create_test_model (var_str ("SM"), test_model)
 
     flv_born = [11, -11, 2, -2]
     flv_real = [11, -11, 2, -2, 21]
     flv_born%n_in = 2; flv_real%n_in = 2
     write (u, "(A)") "* Valid splittings of ee -> uu"
     write (u, "(A)") "Born Flavors: "
     call flv_born%write (u)
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "3, 4 (2, -2) : ", flv_real%valid_pair (3, 4, flv_born, test_model)
     write (u, "(A,L1)") "4, 3 (-2, 2) : ", flv_real%valid_pair (4, 3, flv_born, test_model)
     write (u, "(A,L1)") "3, 5 (2, 21) : ", flv_real%valid_pair (3, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 3 (21, 2) : ", flv_real%valid_pair (5, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 5 (-2, 21): ", flv_real%valid_pair (4, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 4 (21, -2): ", flv_real%valid_pair (5, 4, flv_born, test_model)
     call write_separator (u)
 
     call flv_born%final ()
     call flv_real%final ()
 
     flv_born = [2, -2, 11, -11]
     flv_real = [2, -2, 11, -11, 21]
     flv_born%n_in = 2; flv_real%n_in = 2
     write (u, "(A)") "* Valid splittings of uu -> ee"
     write (u, "(A)") "Born Flavors: "
     call flv_born%write (u)
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "1, 2 (2, -2) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 1 (-2, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
     write (u, "(A,L1)") "5, 2 (21, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 5 (-2, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model)
     write (u, "(A,L1)") "1, 5 (21, 2) : " , flv_real%valid_pair (5, 1, flv_born, test_model)
     write (u, "(A,L1)") "5, 1 (2, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model)
     call flv_real%final ()
     flv_real = [21, -2, 11, -11, -2]
     flv_real%n_in = 2
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "1, 2 (21, -2): " , flv_real%valid_pair (1, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 1 (-2, 21): " , flv_real%valid_pair (2, 1, flv_born, test_model)
     write (u, "(A,L1)") "5, 2 (-2, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 5 (-2, -2): " , flv_real%valid_pair (2, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 1 (-2, 21): " , flv_real%valid_pair (5, 1, flv_born, test_model)
     write (u, "(A,L1)") "1, 5 (21, -2): " , flv_real%valid_pair (1, 5, flv_born, test_model)
     call flv_real%final ()
     flv_real = [2, 21, 11, -11, 2]
     flv_real%n_in = 2
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "1, 2 (2, 21) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 1 (21, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
     write (u, "(A,L1)") "5, 2 (2, 21) : " , flv_real%valid_pair (5, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 5 (21, 2) : " , flv_real%valid_pair (2, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 1 (2, 2)  : " , flv_real%valid_pair (5, 1, flv_born, test_model)
     write (u, "(A,L1)") "1, 5 (2, 2)  : " , flv_real%valid_pair (1, 5, flv_born, test_model)
     call write_separator (u)
 
     call flv_born%final ()
     call flv_real%final ()
 
     flv_born = [11, -11, 2, -2, 21]
     flv_real = [11, -11, 2, -2, 21, 21]
     flv_born%n_in = 2; flv_real%n_in = 2
     write (u, "(A)") "* Valid splittings of ee -> uug"
     write (u, "(A)") "Born Flavors: "
     call flv_born%write (u)
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
     write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
     write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 5 (-2, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 4 (21, -2): " , flv_real%valid_pair (5, 4, flv_born, test_model)
     write (u, "(A,L1)") "3, 6 (2, 21) : " , flv_real%valid_pair (3, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 3 (21, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 6 (-2, 21): " , flv_real%valid_pair (4, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 4 (21, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model)
     write (u, "(A,L1)") "5, 6 (21, 21): " , flv_real%valid_pair (5, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 5 (21, 21): " , flv_real%valid_pair (6, 5, flv_born, test_model)
     call flv_real%final ()
     flv_real = [11, -11, 2, -2, 1, -1]
     flv_real%n_in = 2
     write (u, "(A)") "Real Flavors (exemplary g -> dd splitting): "
     call flv_real%write (u)
     write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
     write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
     write (u, "(A,L1)") "3, 5 (2, 1)  : " , flv_real%valid_pair (3, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 3 (1, 2)  : " , flv_real%valid_pair (5, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 5 (-2, 1) : " , flv_real%valid_pair (4, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 4 (1, -2) : " , flv_real%valid_pair (5, 4, flv_born, test_model)
     write (u, "(A,L1)") "3, 6 (2, -1) : " , flv_real%valid_pair (3, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 3 (-1, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 6 (-2, -1): " , flv_real%valid_pair (4, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 4 (-1, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model)
     write (u, "(A,L1)") "5, 6 (1, -1) : " , flv_real%valid_pair (5, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 5 (-1, 1) : " , flv_real%valid_pair (6, 5, flv_born, test_model)
     call write_separator (u)
 
     call flv_born%final ()
     call flv_real%final ()
 
     flv_born = [6, -5, 2, -1 ]
     flv_real = [6, -5, 2, -1, 21]
     flv_born%n_in = 1; flv_real%n_in = 1
     write (u, "(A)") "* Valid splittings of t -> b u d~"
     write (u, "(A)") "Born Flavors: "
     call flv_born%write (u)
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "1, 2 (6, -5) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
     write (u, "(A,L1)") "1, 3 (6, 2)  : " , flv_real%valid_pair (1, 3, flv_born, test_model)
     write (u, "(A,L1)") "1, 4 (6, -1) : " , flv_real%valid_pair (1, 4, flv_born, test_model)
     write (u, "(A,L1)") "2, 1 (-5, 6) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
     write (u, "(A,L1)") "3, 1 (2, 6)  : " , flv_real%valid_pair (3, 1, flv_born, test_model)
     write (u, "(A,L1)") "4, 1 (-1, 6) : " , flv_real%valid_pair (4, 1, flv_born, test_model)
     write (u, "(A,L1)") "2, 3 (-5, 2) : " , flv_real%valid_pair (2, 3, flv_born, test_model)
     write (u, "(A,L1)") "2, 4 (-5, -1): " , flv_real%valid_pair (2, 4, flv_born, test_model)
     write (u, "(A,L1)") "3, 2 (2, -5) : " , flv_real%valid_pair (3, 2, flv_born, test_model)
     write (u, "(A,L1)") "4, 2 (-1, -5): " , flv_real%valid_pair (4, 2, flv_born, test_model)
     write (u, "(A,L1)") "3, 4 (2, -1) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
     write (u, "(A,L1)") "4, 3 (-1, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
     write (u, "(A,L1)") "1, 5 (6, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 1 (21, 6) : " , flv_real%valid_pair (5, 1, flv_born, test_model)
     write (u, "(A,L1)") "2, 5 (-5, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 2 (21, 5) : " , flv_real%valid_pair (5, 2, flv_born, test_model)
     write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 5 (-1, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 4 (21, -1): " , flv_real%valid_pair (5, 4, flv_born, test_model)
 
     call flv_born%final ()
     call flv_real%final ()
 
   end subroutine fks_regions_1
 
 @ %def fks_regions_1
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_2
 <<fks regions: tests>>=
   subroutine fks_regions_2 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_2"
     write (u, "(A)") "* Create singular regions for processes with up to four singular regions"
     write (u, "(A)") "* ee -> qq with QCD corrections"
     write (u, "(A)")
 
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
 
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, 2, -2]
     flv_real (:, 1) = [11, -11, 2, -2, 21]
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> qq with EW corrections"
     write (u, "(A)")
 
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, 2, -2]
     flv_real (:, 1) = [11, -11, 2, -2, 22]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> tt"
     write (u, "(A)")
     write (u, "(A)") "* This process has four singular regions because they are not equivalent."
 
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 6; n_legs_real = 7
     n_in = 2
 
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, 6, -6, 6, -6]
     flv_real (:, 1) = [11, -11, 6, -6, 6, -6, 21]
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
   end subroutine fks_regions_2
 
 @ %def fks_regions_2
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_3
 <<fks regions: tests>>=
   subroutine fks_regions_3 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in, i, j
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_3"
     write (u, "(A)") "* Create singular regions for processes with three final-state particles"
 
     write (u, "(A)") "* ee -> qqg"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 2
     n_legs_born = 5; n_legs_real = 6
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1) = [11, -11, 2, -2, 21]
     flv_real (:, 1) = [11, -11, 2, -2, 21, 21]
     flv_real (:, 2) = [11, -11, 2, -2, 1, -1]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> qqA"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 2
     n_legs_born = 5; n_legs_real = 6
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1) = [11, -11, 2, -2, 22]
     flv_real (:, 1) = [11, -11, 2, -2, 22, 22]
     flv_real (:, 2) = [11, -11, 2, -2, 11, -11]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> jet jet jet"
     write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
     write (u, "(A)")
     n_flv_born = 5; n_flv_real = 22
     n_legs_born = 5; n_legs_real = 6
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1)  = [11, -11, -4, 4, 21]
     flv_born (:, 2)  = [11, -11, -2, 2, 21]
     flv_born (:, 3)  = [11, -11, -5, 5, 21]
     flv_born (:, 4)  = [11, -11, -3, 3, 21]
     flv_born (:, 5)  = [11, -11, -1, 1, 21]
     flv_real (:, 1)  = [11, -11, -4, -4, 4, 4]
     flv_real (:, 2)  = [11, -11, -4, -2, 2, 4]
     flv_real (:, 3)  = [11, -11, -4, 4, 21, 21]
     flv_real (:, 4)  = [11, -11, -4, -5, 4, 5]
     flv_real (:, 5)  = [11, -11, -4, -3, 4, 3]
     flv_real (:, 6)  = [11, -11, -4, -1, 2, 3]
     flv_real (:, 7)  = [11, -11, -4, -1, 4, 1]
     flv_real (:, 8)  = [11, -11, -2, -2, 2, 2]
     flv_real (:, 9)  = [11, -11, -2, 2, 21, 21]
     flv_real (:, 10) = [11, -11, -2, -5, 2, 5]
     flv_real (:, 11) = [11, -11, -2, -3, 2, 3]
     flv_real (:, 12) = [11, -11, -2, -3, 4, 1]
     flv_real (:, 13) = [11, -11, -2, -1, 2, 1]
     flv_real (:, 14) = [11, -11, -5, -5, 5, 5]
     flv_real (:, 15) = [11, -11, -5, -3, 3, 5]
     flv_real (:, 16) = [11, -11, -5, -1, 1, 5]
     flv_real (:, 17) = [11, -11, -5, 5, 21, 21]
     flv_real (:, 18) = [11, -11, -3, -3, 3, 3]
     flv_real (:, 19) = [11, -11, -3, -1, 1, 3]
     flv_real (:, 20) = [11, -11, -3, 3, 21, 21]
     flv_real (:, 21) = [11, -11, -1, -1, 1, 1]
     flv_real (:, 22) = [11, -11, -1, 1, 21, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> L L A"
     write (u, "(A)") "* with L = e2:E2:e3:E3"
     write (u, "(A)")
     n_flv_born = 2; n_flv_real = 6
     n_legs_born = 5; n_legs_real = 6
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1) = [11, -11, -15, 15, 22]
     flv_born (:, 2) = [11, -11, -13, 13, 22]
 
     flv_real (:, 1) = [11, -11, -15, -15, 15, 15]
     flv_real (:, 2) = [11, -11, -15, -13, 13, 13]
     flv_real (:, 3) = [11, -11, -13, -15, 13, 15]
     flv_real (:, 4) = [11, -11, -15, 15, 22, 22]
     flv_real (:, 5) = [11, -11, -13, -13, 13, 13]
     flv_real (:, 6) = [11, -11, -13, 13, 22, 22]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
   end subroutine fks_regions_3
 
 @ %def fks_regions_3
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_4
 <<fks regions: tests>>=
   subroutine fks_regions_4 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_4"
     write (u, "(A)") "* Create singular regions for processes with four final-state particles"
     write (u, "(A)") "* ee -> 4 jet"
     write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
     write (u, "(A)")
     n_flv_born = 22; n_flv_real = 22
     n_legs_born = 6; n_legs_real = 7
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1)   = [11, -11, -4, -4, 4, 4]
     flv_born (:, 2)   = [11, -11, -4, -2, 2, 4]
     flv_born (:, 3)   = [11, -11, -4, 4, 21, 21]
     flv_born (:, 4)   = [11, -11, -4, -5, 4, 5]
     flv_born (:, 5)   = [11, -11, -4, -3, 4, 3]
     flv_born (:, 6)   = [11, -11, -4, -1, 2, 3]
     flv_born (:, 7)   = [11, -11, -4, -1, 4, 1]
     flv_born (:, 8)   = [11, -11, -2, -2, 2, 2]
     flv_born (:, 9)   = [11, -11, -2, 2, 21, 21]
     flv_born (:, 10)  = [11, -11, -2, -5, 2, 5]
     flv_born (:, 11)  = [11, -11, -2, -3, 2, 3]
     flv_born (:, 12)  = [11, -11, -2, -3, 4, 1]
     flv_born (:, 13)  = [11, -11, -2, -1, 2, 1]
     flv_born (:, 14)  = [11, -11, -5, -5, 5, 5]
     flv_born (:, 15)  = [11, -11, -5, -3, 3, 5]
     flv_born (:, 16)  = [11, -11, -5, -1, 1, 5]
     flv_born (:, 17)  = [11, -11, -5, 5, 21, 21]
     flv_born (:, 18)  = [11, -11, -3, -3, 3, 3]
     flv_born (:, 19)  = [11, -11, -3, -1, 1, 3]
     flv_born (:, 20)  = [11, -11, -3, -3, 21, 21]
     flv_born (:, 21)  = [11, -11, -1, -1, 1, 1]
     flv_born (:, 22)  = [11, -11, -1, 1, 21, 21]
     flv_real (:, 1)   = [11, -11, -4, -4, 4, 4, 21]
     flv_real (:, 2)   = [11, -11, -4, -2, 2, 4, 21]
     flv_real (:, 3)   = [11, -11, -4, 4, 21, 21, 21]
     flv_real (:, 4)   = [11, -11, -4, -5, 4, 5, 21]
     flv_real (:, 5)   = [11, -11, -4, -3, 4, 3, 21]
     flv_real (:, 6)   = [11, -11, -4, -1, 2, 3, 21]
     flv_real (:, 7)   = [11, -11, -4, -1, 4, 1, 21]
     flv_real (:, 8)   = [11, -11, -2, -2, 2, 2, 21]
     flv_real (:, 9)   = [11, -11, -2, 2, 21, 21, 21]
     flv_real (:, 10)  = [11, -11, -2, -5, 2, 5, 21]
     flv_real (:, 11)  = [11, -11, -2, -3, 2, 3, 21]
     flv_real (:, 12)  = [11, -11, -2, -3, 4, 1, 21]
     flv_real (:, 13)  = [11, -11, -2, -1, 2, 1, 21]
     flv_real (:, 14)  = [11, -11, -5, -5, 5, 5, 21]
     flv_real (:, 15)  = [11, -11, -5, -3, 3, 5, 21]
     flv_real (:, 16)  = [11, -11, -5, -1, 1, 5, 21]
     flv_real (:, 17)  = [11, -11, -5, 5, 21, 21, 21]
     flv_real (:, 18)  = [11, -11, -3, -3, 3, 3, 21]
     flv_real (:, 19)  = [11, -11, -3, -1, 1, 3, 21]
     flv_real (:, 20)  = [11, -11, -3, 3, 21, 21, 21]
     flv_real (:, 21)  = [11, -11, -1, -1, 1, 1, 21]
     flv_real (:, 22)  = [11, -11, -1, 1, 21, 21, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> bbmumu with QCD corrections"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 6; n_legs_real = 7
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1)   = [11, -11, -5, 5, -13, 13]
     flv_real (:, 1)   = [11, -11, -5, 5, -13, 13, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> bbmumu with EW corrections"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 6; n_legs_real = 7
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1)   = [11, -11, -5, 5, -13, 13]
     flv_real (:, 1)   = [11, -11, -5, 5, -13, 13, 22]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
   end subroutine fks_regions_4
 
 @ %def fks_regions_4
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_5
 <<fks regions: tests>>=
   subroutine fks_regions_5 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_5"
     write (u, "(A)") "* Create singular regions for processes with five final-state particles"
     write (u, "(A)") "* ee -> 5 jet"
     write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
     write (u, "(A)")
     n_flv_born = 22; n_flv_real = 67
     n_legs_born = 7; n_legs_real = 8
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
 
     flv_born (:,1)  = [11,-11,-4,-4,4,4,21]
     flv_born (:,2)  = [11,-11,-4,-2,2,4,21]
     flv_born (:,3)  = [11,-11,-4,4,21,21,21]
     flv_born (:,4)  = [11,-11,-4,-5,4,5,21]
     flv_born (:,5)  = [11,-11,-4,-3,4,3,21]
     flv_born (:,6)  = [11,-11,-4,-1,2,3,21]
     flv_born (:,7)  = [11,-11,-4,-1,4,1,21]
     flv_born (:,8)  = [11,-11,-2,-2,2,2,21]
     flv_born (:,9)  = [11,-11,-2,2,21,21,21]
     flv_born (:,10) = [11,-11,-2,-5,2,5,21]
     flv_born (:,11) = [11,-11,-2,-3,2,3,21]
     flv_born (:,12) = [11,-11,-2,-3,4,1,21]
     flv_born (:,13) = [11,-11,-2,-1,2,1,21]
     flv_born (:,14) = [11,-11,-5,-5,5,5,21]
     flv_born (:,15) = [11,-11,-5,-3,3,5,21]
     flv_born (:,16) = [11,-11,-5,-1,1,5,21]
     flv_born (:,17) = [11,-11,-5,5,21,21,21]
     flv_born (:,18) = [11,-11,-3,-3,3,3,21]
     flv_born (:,19) = [11,-11,-3,-1,1,3,21]
     flv_born (:,20) = [11,-11,-3,3,21,21,21]
     flv_born (:,21) = [11,-11,-1,-1,1,1,21]
     flv_born (:,22) = [11,-11,-1,1,21,21,21]
 
     flv_real (:,1)  = [11,-11,-4,-4,-4,4,4,4]
     flv_real (:,2)  = [11,-11,-4,-4,-2,2,4,4]
     flv_real (:,3)  = [11,-11,-4,-4,4,4,21,21]
     flv_real (:,4)  = [11,-11,-4,-4,-5,4,4,5]
     flv_real (:,5)  = [11,-11,-4,-4,-3,4,4,3]
     flv_real (:,6)  = [11,-11,-4,-4,-1,2,4,3]
     flv_real (:,7)  = [11,-11,-4,-4,-1,4,4,1]
     flv_real (:,8)  = [11,-11,-4,-2,-2,2,2,4]
     flv_real (:,9)  = [11,-11,-4,-2,2,4,21,21]
     flv_real (:,10) = [11,-11,-4,-2,-5,2,4,5]
     flv_real (:,11) = [11,-11,-4,-2,-3,2,4,3]
     flv_real (:,12) = [11,-11,-4,-2,-3,4,4,1]
     flv_real (:,13) = [11,-11,-4,-2,-1,2,2,3]
     flv_real (:,14) = [11,-11,-4,-2,-1,2,4,1]
     flv_real (:,15) = [11,-11,-4,4,21,21,21,21]
     flv_real (:,16) = [11,-11,-4,-5,4,5,21,21]
     flv_real (:,17) = [11,-11,-4,-5,-5,4,5,5]
     flv_real (:,18) = [11,-11,-4,-5,-3,4,3,5]
     flv_real (:,19) = [11,-11,-4,-5,-1,2,3,5]
     flv_real (:,20) = [11,-11,-4,-5,-1,4,1,5]
     flv_real (:,21) = [11,-11,-4,-3,4,3,21,21]
     flv_real (:,22) = [11,-11,-4,-3,-3,4,3,3]
     flv_real (:,23) = [11,-11,-4,-3,-1,2,3,3]
     flv_real (:,24) = [11,-11,-4,-3,-1,4,1,3]
     flv_real (:,25) = [11,-11,-4,-1,2,3,21,21]
     flv_real (:,26) = [11,-11,-4,-1,4,1,21,21]
     flv_real (:,27) = [11,-11,-4,-1,-1,2,1,3]
     flv_real (:,28) = [11,-11,-4,-1,-1,4,1,1]
     flv_real (:,29) = [11,-11,-2,-2,-2,2,2,2]
     flv_real (:,30) = [11,-11,-2,-2,2,2,21,21]
     flv_real (:,31) = [11,-11,-2,-2,-5,2,2,5]
     flv_real (:,32) = [11,-11,-2,-2,-3,2,2,3]
     flv_real (:,33) = [11,-11,-2,-2,-3,2,4,1]
     flv_real (:,34) = [11,-11,-2,-2,-1,2,2,1]
     flv_real (:,35) = [11,-11,-2,2,21,21,21,21]
     flv_real (:,36) = [11,-11,-2,-5,2,5,21,21]
     flv_real (:,37) = [11,-11,-2,-5,-5,2,5,5]
     flv_real (:,38) = [11,-11,-2,-5,-3,2,3,5]
     flv_real (:,39) = [11,-11,-2,-5,-3,4,1,5]
     flv_real (:,40) = [11,-11,-2,-5,-1,2,1,5]
     flv_real (:,41) = [11,-11,-2,-3,2,3,21,21]
     flv_real (:,42) = [11,-11,-2,-3,4,1,21,21]
     flv_real (:,43) = [11,-11,-2,-3,-3,2,3,3]
     flv_real (:,44) = [11,-11,-2,-3,-3,4,1,3]
     flv_real (:,45) = [11,-11,-2,-3,-1,2,1,3]
     flv_real (:,46) = [11,-11,-2,-3,-1,4,1,1]
     flv_real (:,47) = [11,-11,-2,-1,2,1,21,21]
     flv_real (:,48) = [11,-11,-2,-1,-1,2,1,1]
     flv_real (:,49) = [11,-11,-5,-5,-5,5,5,5]
     flv_real (:,50) = [11,-11,-5,-5,-3,3,5,5]
     flv_real (:,51) = [11,-11,-5,-5,-1,1,5,5]
     flv_real (:,52) = [11,-11,-5,-5,5,5,21,21]
     flv_real (:,53) = [11,-11,-5,-3,-3,3,3,5]
     flv_real (:,54) = [11,-11,-5,-3,-1,1,3,5]
     flv_real (:,55) = [11,-11,-5,-3,3,5,21,21]
     flv_real (:,56) = [11,-11,-5,-1,-1,1,1,5]
     flv_real (:,57) = [11,-11,-5,-1,1,5,21,21]
     flv_real (:,58) = [11,-11,-5,5,21,21,21,21]
     flv_real (:,59) = [11,-11,-3,-3,-3,3,3,3]
     flv_real (:,60) = [11,-11,-3,-3,-1,1,3,3]
     flv_real (:,61) = [11,-11,-3,-3,3,3,21,21]
     flv_real (:,62) = [11,-11,-3,-1,-1,1,1,3]
     flv_real (:,63) = [11,-11,-3,-1,1,3,21,21]
     flv_real (:,64) = [11,-11,-3,3,21,21,21,21]
     flv_real (:,65) = [11,-11,-1,-1,-1,1,1,1]
     flv_real (:,66) = [11,-11,-1,-1,1,1,21,21]
     flv_real (:,67) = [11,-11,-1,1,21,21,21,21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
   end subroutine fks_regions_5
 
 @ %def fks_regions_5
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_6
 <<fks regions: tests>>=
   subroutine fks_regions_6 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     integer :: i, j
     integer, dimension(10) :: flavors
     write (u, "(A)") "* Test output: fks_regions_6"
     write (u, "(A)") "* Create table of singular regions for Drell Yan"
     write (u, "(A)")
 
     n_flv_born = 10; n_flv_real = 30
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flavors = [-5, -4, -3, -2, -1, 1, 2, 3, 4, 5]
     do i = 1, n_flv_born
        flv_born (3:4, i) = [11, -11]
     end do
     do j = 1, n_flv_born
        flv_born (1, j) = flavors (j)
        flv_born (2, j) = -flavors (j)
     end do
 
     do i = 1, n_flv_real
        flv_real (3:4, i) = [11, -11]
     end do
     i = 1
     do j = 1, n_flv_real
        if (mod (j, 3) == 1) then
           flv_real (1, j) = flavors (i)
           flv_real (2, j) = -flavors (i)
           flv_real (5, j) = 21
        else if (mod (j, 3) == 2) then
           flv_real (1, j) = flavors (i)
           flv_real (2, j) = 21
           flv_real (5, j) = flavors (i)
        else
           flv_real (1, j) = 21
           flv_real (2, j) = -flavors (i)
           flv_real (5, j) = -flavors (i)
           i = i + 1
        end if
     end do
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     call write_separator (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
     write (u, "(A)") "* Create table of singular regions for hadronic top decay"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 4; n_legs_real = 5
     n_in = 1
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1) = [6, -5, 2, -1]
     flv_real (:, 1) = [6, -5, 2, -1, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     call write_separator (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
     write (u, "(A)") "* Create table of singular regions for dijet s sbar -> jet jet"
     write (u, "(A)") "* With jet = u:d:gl"
     write (u, "(A)")
 
     n_flv_born = 3; n_flv_real = 3
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     do i = 1, n_flv_born
        flv_born (1:2, i) = [3, -3]
     end do
     flv_born (3, :) = [1, 2, 21]
     flv_born (4, :) = [-1, -2, 21]
 
     do i = 1, n_flv_real
        flv_real (1:2, i) = [3, -3]
     end do
     flv_real (3, :) = [1, 2, 21]
     flv_real (4, :) = [-1, -2, 21]
     flv_real (5, :) = [21, 21, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
     call reg_data%final ()
 
   end subroutine fks_regions_6
 
 @ %def fks_regions_6
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_7
 <<fks regions: tests>>=
   subroutine fks_regions_7 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_7"
     write (u, "(A)") "* Create table of singular regions for ee -> qq"
     write (u, "(A)")
 
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
 
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, 2, -2]
     flv_real (:, 1) = [11, -11, 2, -2, 21]
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%write_latex (u)
     call reg_data%final ()
 
   end subroutine fks_regions_7
 
 @ %def fks_regions_7
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_8
 <<fks regions: tests>>=
   subroutine fks_regions_8 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     integer :: i, j
     integer, dimension(10) :: flavors
     write (u, "(A)") "* Test output: fks_regions_8"
     write (u, "(A)") "* Create table of singular regions for ee -> ee"
     write (u, "(A)")
 
     n_flv_born = 1; n_flv_real = 3
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, -11, 11]
 
     flv_real (:, 1) = [11, -11, -11, 11, 22]
     flv_real (:, 2) = [11, 22, -11, 11, 11]
     flv_real (:, 3) = [22, -11, 11, -11, -11]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
     call reg_data%final ()
 
   end subroutine fks_regions_8
 
 @ %def fks_regions_8
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Virtual contribution to the cross section}
 <<[[virtual.f90]]>>=
 <<File header>>
 
 module virtual
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use numeric_utils
   use constants
   use diagnostics
   use pdg_arrays
   use models
   use model_data, only: model_data_t
   use physics_defs
   use sm_physics
   use lorentz
   use flavors
   use nlo_data, only: get_threshold_momenta, nlo_settings_t
   use nlo_data, only: ASSOCIATED_LEG_PAIR
   use fks_regions
 
 <<Standard module head>>
 
 <<virtual: public>>
 
 <<virtual: parameters>>
 
 <<virtual: types>>
 
 contains
 
 <<virtual: procedures>>
 
 end module virtual
 @ %def virtual
 @
 <<virtual: public>>=
   public :: virtual_t
 <<virtual: types>>=
   type :: virtual_t
      type(nlo_settings_t), pointer :: settings
      real(default), dimension(:,:), allocatable :: gamma_0, gamma_p, c_flv
      real(default) :: ren_scale2, fac_scale, es_scale2
      integer, dimension(:), allocatable :: n_is_neutrinos
      integer :: n_in, n_legs, n_flv
      logical :: bad_point = .false.
      type(string_t) :: selection
      real(default), dimension(:), allocatable :: sqme_born
      real(default), dimension(:), allocatable :: sqme_virt_fin
      real(default), dimension(:,:,:), allocatable :: sqme_color_c
      real(default), dimension(:,:,:), allocatable :: sqme_charge_c
      logical :: has_pdfs = .false.
    contains
    <<virtual: virtual: TBP>>
   end type virtual_t
 
 @ %def virtual_t
 @
 <<virtual: virtual: TBP>>=
   procedure :: init => virtual_init
 <<virtual: procedures>>=
   subroutine virtual_init (virt, flv_born, n_in, settings, &
       nlo_corr_type, model, has_pdfs)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in), dimension(:,:) :: flv_born
     integer, intent(in) :: n_in
     type(nlo_settings_t), intent(in), pointer :: settings
     type(string_t), intent(in) :: nlo_corr_type
     class(model_data_t), intent(in) :: model
     logical, intent(in) :: has_pdfs
     integer :: i_flv
     virt%n_legs = size (flv_born, 1); virt%n_flv = size (flv_born, 2)
     virt%n_in = n_in
     allocate (virt%sqme_born (virt%n_flv))
     allocate (virt%sqme_virt_fin (virt%n_flv))
     allocate (virt%sqme_color_c (virt%n_legs, virt%n_legs, virt%n_flv))
     allocate (virt%sqme_charge_c (virt%n_legs, virt%n_legs, virt%n_flv))
     allocate (virt%gamma_0 (virt%n_legs, virt%n_flv), &
        virt%gamma_p (virt%n_legs, virt%n_flv), &
        virt%c_flv (virt%n_legs, virt%n_flv))
     call virt%init_constants (flv_born, settings%fks_template%n_f, nlo_corr_type, model)
     allocate (virt%n_is_neutrinos (virt%n_flv))
     virt%n_is_neutrinos = 0
     do i_flv = 1, virt%n_flv
        if (is_neutrino (flv_born(1, i_flv))) &
           virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1
        if (is_neutrino (flv_born(2, i_flv))) &
           virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1
     end do
     select case (char (settings%virtual_selection))
     case ("Full", "OLP", "Subtraction")
        virt%selection = settings%virtual_selection
     case default
        call msg_fatal ('Virtual selection: Possible values are "Full", "OLP" or "Subtraction')
     end select
     virt%settings => settings
     virt%has_pdfs = has_pdfs
   contains
 
     function is_neutrino (flv) result (neutrino)
       integer, intent(in) :: flv
       logical :: neutrino
       neutrino = (abs(flv) == 12 .or. abs(flv) == 14 .or. abs(flv) == 16)
     end function is_neutrino
 
   end subroutine virtual_init
 
 @ %def virtual_init
 @ The virtual subtraction terms contain Casimir operators and derived constants, listed
 below:
 \begin{align}
   \label{eqn:C(q)}
   C(q) = C(\bar{q}) &= C_F, \\
   \label{eqn:C(g)}
   C(g) &= C_A,\\
   \label{eqn:gamma(q)}
   \gamma(q) = \gamma(\bar{q}) &= \frac{3}{2} C_F,\\
   \label{eqn:gamma(g)}
   \gamma(g) &= \frac{11}{6} C_A - \frac{2}{3} T_F N_f,\\
   \label{eqn:gammap(q)}
   \gamma'(q) = \gamma'(\bar{q}) &= \left(\frac{13}{2} - \frac{2\pi^2}{3}\right) C_F, \\
   \label{eqn:gammap(g)}
   \gamma'(g) &= \left(\frac{67}{9} - \frac{2\pi^2}{3}\right) C_A - \frac{23}{9} T_F N_f.
 \end{align}
 For uncolored particles, [[virtual_init_constants]] sets $C$, $\gamma$ and $\gamma'$ to zero.
 <<virtual: virtual: TBP>>=
   procedure :: init_constants => virtual_init_constants
 <<virtual: procedures>>=
   subroutine virtual_init_constants (virt, flv_born, nf_input, nlo_corr_type, model)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in), dimension(:,:) :: flv_born
     integer, intent(in) :: nf_input
     type(string_t), intent(in) :: nlo_corr_type
     class(model_data_t), intent(in) :: model
     integer :: i_part, i_flv
     real(default) :: nf, CA_factor
     real(default), dimension(:,:), allocatable :: CF_factor, TR_factor
     type(flavor_t) :: flv
     allocate (CF_factor (size (flv_born, 1), size (flv_born, 2)), &
          TR_factor (size (flv_born, 1), size (flv_born, 2)))
     select case (char (nlo_corr_type))
     case ("QCD")
        CA_factor = CA; CF_factor = CF; TR_factor = TR
        nf = real(nf_input, default)
     case ("EW")
        CA_factor = zero
        do i_flv = 1, size (flv_born, 2)
           do i_part = 1, size (flv_born, 1)
              call flv%init (flv_born(i_part, i_flv), model)
              CF_factor(i_part, i_flv) = (flv%get_charge ())**2
              TR_factor(i_part, i_flv) = (flv%get_charge ())**2
           end do
        end do
        ! TODO vincent_r fixed nf needs replacement  !!! for testing only, needs dynamical treatment!
        nf = real(4, default)
     end select
     do i_flv = 1, size (flv_born, 2)
        do i_part = 1, size (flv_born, 1)
           if (is_corresponding_vector (flv_born(i_part, i_flv), nlo_corr_type)) then
              virt%gamma_0(i_part, i_flv) = 11._default / 6._default * CA_factor &
                   - two / three * TR_factor(i_part, i_flv) * nf
              virt%gamma_p(i_part, i_flv) = (67._default / 9._default &
                   - two * pi**2 / three) * CA_factor &
                   - 23._default / 9._default * TR_factor(i_part, i_flv) * nf
              virt%c_flv(i_part, i_flv) = CA_factor
           else if (is_corresponding_fermion (flv_born(i_part, i_flv), nlo_corr_type)) then
              virt%gamma_0(i_part, i_flv) = 1.5_default * CF_factor(i_part, i_flv)
              virt%gamma_p(i_part, i_flv) = (6.5_default - two * pi**2 / three) * CF_factor(i_part, i_flv)
              virt%c_flv(i_part, i_flv) = CF_factor(i_part, i_flv)
           else
              virt%gamma_0(i_part, i_flv) = zero
              virt%gamma_p(i_part, i_flv) = zero
              virt%c_flv(i_part, i_flv) = zero
           end if
        end do
     end do
   contains
     function is_corresponding_vector (pdg_nr, nlo_corr_type)
       logical :: is_corresponding_vector
       integer, intent(in) :: pdg_nr
       type(string_t), intent(in) :: nlo_corr_type
       is_corresponding_vector = .false.
       if (nlo_corr_type == "QCD") then
          is_corresponding_vector = is_gluon (pdg_nr)
       else if (nlo_corr_type == "EW") then
          is_corresponding_vector = is_photon (pdg_nr)
       end if
     end function is_corresponding_vector
     function is_corresponding_fermion (pdg_nr, nlo_corr_type)
       logical :: is_corresponding_fermion
       integer, intent(in) :: pdg_nr
       type(string_t), intent(in) :: nlo_corr_type
       is_corresponding_fermion = .false.
       if (nlo_corr_type == "QCD") then
          is_corresponding_fermion = is_quark (pdg_nr)
       else if (nlo_corr_type == "EW") then
          is_corresponding_fermion = is_fermion (pdg_nr)
       end if
     end function is_corresponding_fermion
   end subroutine virtual_init_constants
 
 @ %def virtual_init_constants
 @ Set the renormalization scale. If the input is zero, use the
 center-of-mass energy.
 <<virtual: virtual: TBP>>=
   procedure :: set_ren_scale => virtual_set_ren_scale
 <<virtual: procedures>>=
   subroutine virtual_set_ren_scale (virt, p, ren_scale)
     class(virtual_t), intent(inout) :: virt
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: ren_scale
     if (ren_scale > 0) then
       virt%ren_scale2 = ren_scale**2
     else
       virt%ren_scale2 = (p(1) + p(2))**2
     end if
   end subroutine virtual_set_ren_scale
 
 @ %def virtual_set_ren_scale
 @
 <<virtual: virtual: TBP>>=
   procedure :: set_fac_scale => virtual_set_fac_scale
 <<virtual: procedures>>=
   subroutine virtual_set_fac_scale (virt, p, fac_scale)
     class(virtual_t), intent(inout) :: virt
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), optional :: fac_scale
     if (present (fac_scale)) then
        virt%fac_scale = fac_scale
     else
        virt%fac_scale = (p(1) + p(2))**1
     end if
   end subroutine virtual_set_fac_scale
 
 @ %def virtual_set_fac_scale
 <<virtual: virtual: TBP>>=
   procedure :: set_ellis_sexton_scale => virtual_set_ellis_sexton_scale
 <<virtual: procedures>>=
   subroutine virtual_set_ellis_sexton_scale (virt, Q)
     class(virtual_t), intent(inout) :: virt
     real(default), intent(in) :: Q
     virt%es_scale2 = Q * Q
   end subroutine virtual_set_ellis_sexton_scale
 
 @ %def virtual_set_ellis_sexton_scale
 @ The virtual-subtracted matrix element is given by the equation
 \begin{equation}
   \label{eqn:virt_sub}
   \mathcal{V} = \frac{\alpha_s}{2\pi}\left(\mathcal{Q}\mathcal{B} +
   \sum \mathcal{I}_{ij}\mathcal{B}_{ij} + \mathcal{V}_{fin}\right),
 \end{equation}
 The expressions for $\mathcal{Q}$ can be found in equations \ref{eqn:virt_Q_isr}
 and \ref{eqn:virt_Q_fsr}.
 The expressions for $\mathcal{I}_{ij}$ can be found in equations
 (\ref{I_00}), (\ref{I_mm}), (\ref{I_0m}), depending on whether the
 particles involved in the radiation process are massive or massless.
+
+If two or more flavor structures would produce the same amplitude we only compute
+one and use the [[eqv_index]] to copy the result to the others (if [[reuse_amplitudes_fks]]
+is true).
 <<virtual: virtual: TBP>>=
   procedure :: evaluate => virtual_evaluate
 <<virtual: procedures>>=
   subroutine virtual_evaluate (virt, reg_data, alpha_coupling, &
          p_born, separate_uborns, sqme_virt)
     class(virtual_t), intent(inout) :: virt
     type(region_data_t), intent(in) :: reg_data
     real(default), intent(in) :: alpha_coupling
     type(vector4_t), intent(in), dimension(:)  :: p_born
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), intent(inout) :: sqme_virt
+    integer, dimension(:), allocatable :: eqv_flv_index
+    real(default), dimension(:), allocatable :: sqme_virt_arr
     real(default) :: s, s_o_Q2
     real(default), dimension(reg_data%n_flv_born) :: QB, BI
     integer :: i_flv, ii_flv
+    logical, dimension(:), allocatable :: flv_evaluated
     QB = zero; BI = zero
+    allocate (flv_evaluated(reg_data%n_flv_born))
+    allocate (sqme_virt_arr(reg_data%n_flv_born))
+    sqme_virt_arr = zero
+    flv_evaluated = .false.
     if (virt%bad_point) return
     if (debug2_active (D_VIRTUAL)) then
        print *, 'Compute virtual component using alpha = ', alpha_coupling
        print *, 'Virtual selection: ', char (virt%selection)
        print *, 'virt%es_scale2 =    ', virt%es_scale2 !!! Debugging
     end if
     s = sum (p_born(1 : virt%n_in))**2
     if (virt%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
          call set_s_for_threshold ()
     s_o_Q2 = s / virt%es_scale2 * virt%settings%fks_template%xi_cut**2
+    eqv_flv_index = reg_data%eqv_flv_index_born
     do i_flv = 1, reg_data%n_flv_born
-       if (separate_uborns) then
-          ii_flv = i_flv
+       if (.not. flv_evaluated(eqv_flv_index(i_flv))) then
+          if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("OLP")) then
+             !!! A factor of alpha_coupling/twopi is assumed to be included in vfin
+             sqme_virt_arr(i_flv) = sqme_virt_arr(i_flv) + virt%sqme_virt_fin(i_flv)
+          end if
+          if (virt%selection == var_str ("Full") .or. &
+               virt%selection == var_str ("Subtraction")) then
+             call virt%evaluate_initial_state (i_flv, QB)
+             call virt%compute_collinear_contribution (i_flv, p_born, sqrt(s), reg_data, QB)
+             select case (virt%settings%factorization_mode)
+             case (FACTORIZATION_THRESHOLD)
+                call virt%compute_eikonals_threshold (i_flv, p_born, s_o_Q2, QB, BI)
+             case default
+                call virt%compute_massive_self_eikonals (i_flv, p_born, s_o_Q2, reg_data, QB)
+                call virt%compute_eikonals (i_flv, p_born, s_o_Q2, reg_data, BI)
+             end select
+             if (debug2_active (D_VIRTUAL)) then
+                print *, 'Evaluate i_flv: ', i_flv
+                print *, 'sqme_born: ', virt%sqme_born (i_flv)
+                print *, 'Q * sqme_born: ', alpha_coupling / twopi * QB(i_flv)
+                print *, 'BI: ', alpha_coupling / twopi * BI(i_flv)
+                print *, 'vfin: ', virt%sqme_virt_fin (i_flv)
+             end if
+             sqme_virt_arr(i_flv) = &
+                  sqme_virt_arr(i_flv) + alpha_coupling / twopi * (QB(i_flv) + BI(i_flv))
+          end if
+          if (.not. (debug_active (D_VIRTUAL) .or. &
+               debug2_active (D_VIRTUAL))) flv_evaluated(eqv_flv_index(i_flv)) = .true.
        else
-          ii_flv = 1
+          sqme_virt_arr(i_flv) = sqme_virt_arr(eqv_flv_index(i_flv))
        end if
-       if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("OLP")) then
-          !!! A factor of alpha_coupling/twopi is assumed to be included in vfin
-          sqme_virt(ii_flv) = sqme_virt(ii_flv) + virt%sqme_virt_fin(i_flv)
-       end if
-       if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("Subtraction")) then
-          call virt%evaluate_initial_state (i_flv, QB)
-          call virt%compute_collinear_contribution (i_flv, p_born, sqrt(s), reg_data, QB)
-          select case (virt%settings%factorization_mode)
-          case (FACTORIZATION_THRESHOLD)
-             call virt%compute_eikonals_threshold (i_flv, p_born, s_o_Q2, QB, BI)
-          case default
-             call virt%compute_massive_self_eikonals (i_flv, p_born, s_o_Q2, reg_data, QB)
-             call virt%compute_eikonals (i_flv, p_born, s_o_Q2, reg_data, BI)
-          end select
-          if (debug2_active (D_VIRTUAL)) then
-             print *, 'Evaluate i_flv: ', i_flv
-             print *, 'sqme_born: ', virt%sqme_born (i_flv)
-             print *, 'Q * sqme_born: ', alpha_coupling / twopi * QB(i_flv)
-             print *, 'BI: ', alpha_coupling / twopi * BI(i_flv)
-             print *, 'vfin: ', virt%sqme_virt_fin (i_flv)
-          end if
-          sqme_virt(ii_flv) = &
-               sqme_virt(ii_flv) + alpha_coupling / twopi * (QB(i_flv) + BI(i_flv))
+       if (separate_uborns) then
+          sqme_virt(i_flv) = sqme_virt(i_flv) + sqme_virt_arr(i_flv)
+       else
+          sqme_virt(1) = sqme_virt(1) + sqme_virt_arr(i_flv)
        end if
     end do
     if (debug2_active (D_VIRTUAL)) then
        call msg_debug2 (D_VIRTUAL, "virtual-subtracted matrix element(s): ")
        print *, sqme_virt
     end if
     do i_flv = 1, reg_data%n_flv_born
        if (virt%n_is_neutrinos(i_flv) > 0) &
             sqme_virt = sqme_virt * virt%n_is_neutrinos(i_flv) * two
     end do
   contains
     subroutine set_s_for_threshold ()
       use ttv_formfactors, only: m1s_to_mpole
       real(default) :: mtop2
       mtop2 = m1s_to_mpole (sqrt(s))**2
       if (s < four * mtop2) s = four * mtop2
     end subroutine set_s_for_threshold
 
   end subroutine virtual_evaluate
 
 @ %def virtual_evaluate
 @
 <<virtual: virtual: TBP>>=
   procedure :: compute_eikonals => virtual_compute_eikonals
 <<virtual: procedures>>=
   subroutine virtual_compute_eikonals (virtual, i_flv, &
            p_born, s_o_Q2, reg_data, BI)
     class(virtual_t), intent(inout) :: virtual
     integer, intent(in) :: i_flv
     type(vector4_t), intent(in), dimension(:)  :: p_born
     real(default), intent(in) :: s_o_Q2
     type(region_data_t), intent(in) :: reg_data
     real(default), intent(inout), dimension(:) :: BI
     integer :: i, j
     real(default) :: I_ij, BI_tmp
     BI_tmp = zero
     ! TODO vincent_r: Split the procedure into one computing QCD eikonals and one computing QED eikonals.
     ! TODO vincent_r: In the best case, remove the dependency on reg_data completely.
     associate (flst_born => reg_data%flv_born(i_flv), &
             nlo_corr_type => reg_data%regions(1)%nlo_correction_type)
        do i = 1, virtual%n_legs
           do j = 1, virtual%n_legs
              if (i /= j) then
                 if (nlo_corr_type == "QCD") then
                    if (flst_born%colored(i) .and. flst_born%colored(j)) then
                       I_ij = compute_eikonal_factor (p_born, flst_born%massive, &
                            i, j, s_o_Q2)
                       BI_tmp = BI_tmp + virtual%sqme_color_c (i, j, i_flv) * I_ij
                       if (debug2_active (D_VIRTUAL)) &
                            print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
                    end if
                 else if (nlo_corr_type == "EW") then
                    I_ij = compute_eikonal_factor (p_born, flst_born%massive, &
                         i, j, s_o_Q2)
                    BI_tmp = BI_tmp + virtual%sqme_charge_c (i, j, i_flv) * I_ij
                    if (debug2_active (D_VIRTUAL)) &
                         print *, 'b_ij: ', virtual%sqme_charge_c (i, j, i_flv), 'I_ij: ', I_ij
                 end if
              else if (debug2_active (D_VIRTUAL)) then
                 print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
              end if
           end do
        end do
        if (virtual%settings%use_internal_color_correlations .or. nlo_corr_type == "EW") &
             BI_tmp = BI_tmp * virtual%sqme_born (i_flv)
     end associate
     BI(i_flv) = BI(i_flv) + BI_tmp
   end subroutine virtual_compute_eikonals
 
 @ %def virtual_compute_eikonals
 @
 <<virtual: virtual: TBP>>=
   procedure :: compute_eikonals_threshold => virtual_compute_eikonals_threshold
 <<virtual: procedures>>=
   subroutine virtual_compute_eikonals_threshold (virtual, i_flv, &
          p_born, s_o_Q2, QB, BI)
     class(virtual_t), intent(in) :: virtual
     integer, intent(in) :: i_flv
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: s_o_Q2
     real(default), intent(inout), dimension(:) :: QB
     real(default), intent(inout), dimension(:) :: BI
     type(vector4_t), dimension(4) :: p_thr
     integer :: leg
     BI = zero; p_thr = get_threshold_momenta (p_born)
     call compute_massive_self_eikonals (virtual%sqme_born(i_flv), QB(i_flv))
     do leg = 1, 2
        BI(i_flv) = BI(i_flv) + evaluate_leg_pair (ASSOCIATED_LEG_PAIR(leg), i_flv)
     end do
   contains
     subroutine compute_massive_self_eikonals (sqme_born, QB)
       real(default), intent(in) :: sqme_born
       real(default), intent(inout) :: QB
       integer :: i
       if (debug_on) call msg_debug2 (D_VIRTUAL, "compute_massive_self_eikonals")
       if (debug_on) call msg_debug2 (D_VIRTUAL, "s_o_Q2", s_o_Q2)
       if (debug_on) call msg_debug2 (D_VIRTUAL, "log (s_o_Q2)", log (s_o_Q2))
       do i = 1, 4
          QB = QB - (cf * (log (s_o_Q2) - 0.5_default * I_m_eps (p_thr(i)))) &
               * sqme_born
       end do
     end subroutine compute_massive_self_eikonals
 
     function evaluate_leg_pair (i_start, i_flv) result (b_ij_times_I)
       real(default) :: b_ij_times_I
       integer, intent(in) :: i_start, i_flv
       real(default) :: I_ij
       integer :: i, j
       b_ij_times_I = zero
       do i = i_start, i_start + 1
          do j = i_start, i_start + 1
             if (i /= j) then
                I_ij = compute_eikonal_factor &
                     (p_thr, [.true., .true., .true., .true.], i, j, s_o_Q2)
                b_ij_times_I = b_ij_times_I + &
                     virtual%sqme_color_c (i, j, i_flv) * I_ij
                if (debug2_active (D_VIRTUAL)) &
                   print *, 'b_ij: ', virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
             end if
          end do
       end do
       if (virtual%settings%use_internal_color_correlations) &
            b_ij_times_I = b_ij_times_I * virtual%sqme_born (i_flv)
       if (debug2_active (D_VIRTUAL)) then
          print *, 'internal color: ', virtual%settings%use_internal_color_correlations
          print *, 'b_ij_times_I =    ', b_ij_times_I
          print *, 'QB           =    ', QB
       end if
     end function evaluate_leg_pair
   end subroutine virtual_compute_eikonals_threshold
 
 @ %def virtual_compute_eikonals_threshold
 @
 <<virtual: virtual: TBP>>=
   procedure :: set_bad_point => virtual_set_bad_point
 <<virtual: procedures>>=
   subroutine virtual_set_bad_point (virt, value)
      class(virtual_t), intent(inout) :: virt
      logical, intent(in) :: value
      virt%bad_point = value
   end subroutine virtual_set_bad_point
 
 @  %def virtual_set_bad_point
 @ The collinear limit of $\tilde{\mathcal{R}}$ can be integrated over the radiation
 degrees of freedom, giving the collinear contribution to the virtual component. Its
 general structure is $\mathcal{Q} \cdot \mathcal{B}$. The initial-state contribution
 to $\mathcal{Q}$ is simply given by
 \begin{equation}
   \label{eqn:virt_Q_isr}
   \mathcal{Q} = -\log\frac{\mu_F^2}{Q^2} \left(\gamma(\mathcal{I}_1) + 2 C (\mathcal{I}_1) \log(\xi_{\text{cut}}) + \gamma(\mathcal{I}_2) + 2 C (\mathcal{I}_2) \log(\xi_{\text{cut}}) \right),
 \end{equation}
 where $Q^2$ is the Ellis-Sexton scale and $\gamma$ is as in eqns. \ref{eqn:gamma(q)}
 and \ref{eqn:gamma(g)}.\\
 [[virtual_evaluate_initial_state]] computes this quantity. The loop over the
 initial-state particles is only executed if we are
 dealing with a scattering process, because for decays there are no virtual
 initial-initial interactions.
 <<virtual: virtual: TBP>>=
   procedure :: evaluate_initial_state => virtual_evaluate_initial_state
 <<virtual: procedures>>=
   subroutine virtual_evaluate_initial_state (virt, i_flv, QB)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in) :: i_flv
     real(default), intent(inout), dimension(:) :: QB
     integer :: i
     if (virt%n_in == 2) then
        do i = 1, virt%n_in
           QB(i_flv) = QB(i_flv) - (virt%gamma_0 (i, i_flv) + two * virt%c_flv(i, i_flv) &
                * log (virt%settings%fks_template%xi_cut)) &
                * log(virt%fac_scale**2 / virt%es_scale2) * virt%sqme_born (i_flv)
        end do
     end if
   end subroutine virtual_evaluate_initial_state
 
 @ %def virtual_evaluate_initial_state
 @ Same as above, but for final-state particles. The collinear limit for final-state
 particles follows from the integral
 \begin{equation*}
   I_{+,\alpha_r} = \int d\Phi_{n+1} \frac{\xi_+^{-1-2\epsilon}}{\xi^{-1-2\epsilon}} \mathcal{R}_{\alpha_r}.
 \end{equation*}
 We can distinguish three situations:
 \begin{enumerate}
   \item $\alpha_r$ contains a massive emitter. In this case, no collinear subtraction term is required and
         the integral above is irrelevant.
   \item $\alpha_r$ contains a massless emitter, but resonances are not taken into account in the subtraction.
         Here, $\xi_{max} = \frac{2E_{em}}{\sqrt{s}}$ is the upper bound on $\xi$.
   \item $\alpha_r$ contains a massless emitter and resonance-aware subtraction is used. Here,
         $\xi_{max} = \frac{2E_{em}}{\sqrt{k_{res}^2}}$.
 \end{enumerate}
 Before version 2.4, only situations 1 and 2 were covered. The difference between situation 2 and 3 comes
 from the expansion of the plus-distribution in the integral above,
 \begin{equation*}
   \xi_+^{-1-2\epsilon} = \xi^{-1-2\epsilon} + \frac{1}{2\epsilon}\delta(\xi)
        = \xi_{max}^{-1-2\epsilon}\left[(1-z)^{-1-2\epsilon} + \frac{\xi_{max}^{2\epsilon}}{2\epsilon}\delta(1-z)\right].
 \end{equation*}
 The expression from the standard FKS literature is given by
 $\mathcal{Q}$ is given by
 \begin{equation}
   \label{eqn:virt_Q_fsr_old}
   \begin{split}
    \mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k)
         - \log\frac{s\delta_o}{2Q^2}\left(\gamma(\mathcal{I}_k)
         - 2C(\mathcal{I}_k) \log\frac{2E_k}{\xi_{\text{cut}}\sqrt{s}}\right) \right.\\
         + \left. 2C(\mathcal{I}_k) \left( \log^2\frac{2E_k}{\sqrt{s}} - \log^2 \xi_{\text{cut}} \right)
         - 2\gamma(\mathcal{I}_k)\log\frac{2E_k}{\sqrt{s}}\right].
   \end{split}
 \end{equation}
 $n_L^{(B)}$ is the number of legs at Born level.
 Here, $\xi_{max}$ is implicitly present in the ratios in the logarithms. Using the resonance-aware $\xi_{max}$ yields
 \begin{equation}
   \label{eqn:virt_Q_fsr}
   \begin{split}
     \mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k)
          + 2\left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max}\right)
            \left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max} + \log\frac{Q^2}{s}\right) C(\mathcal{I}_k) \right.\\
          + \left. 2 \log\xi_{max} \left(\log\xi_{max} - \log\frac{Q^2}{k_{res}^2}\right) C(\mathcal{I}_k)
          + \left(\log\frac{Q^2}{k_{res}^2} - 2 \log\xi_{max}\right) \gamma(\mathcal{I}_k)\right].
   \end{split}
 \end{equation}
 Equation \ref{eqn:virt_Q_fsr} leads to \ref{eqn:virt_Q_fsr_old} with the substitutions $\xi_{max} \rightarrow \frac{2E_{em}}{\sqrt{s}}$ and $k_{res}^2 \rightarrow s$.
 [[virtual_compute_collinear_contribution]] only implements the second one.
 <<virtual: virtual: TBP>>=
   procedure :: compute_collinear_contribution &
      => virtual_compute_collinear_contribution
 <<virtual: procedures>>=
   subroutine virtual_compute_collinear_contribution (virt, i_flv, &
            p_born, sqrts, reg_data, QB)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in) :: i_flv
     type(vector4_t), dimension(:), intent(in) :: p_born
     real(default), intent(in) :: sqrts
     type(region_data_t), intent(in) :: reg_data
     real(default), intent(inout), dimension(:) :: QB
     real(default) :: s1, s2, s3, s4, s5
     integer :: alr, em
     real(default) :: E_em, xi_max, log_xi_max, E_tot2
     logical, dimension(virt%n_flv, virt%n_legs) :: evaluated
     integer :: i_contr
     type(vector4_t) :: k_res
     type(lorentz_transformation_t) :: L_to_resonance
     evaluated = .false.
     do alr = 1, reg_data%n_regions
        if (i_flv /= reg_data%regions(alr)%uborn_index) cycle
        em = reg_data%regions(alr)%emitter
        if (em <= virt%n_in) cycle
        if (evaluated(i_flv, em)) cycle
        !!! Collinear terms only for massless particles
        if (reg_data%regions(alr)%flst_uborn%massive(em)) cycle
        E_em = p_born(em)%p(0)
        if (allocated (reg_data%alr_contributors)) then
           i_contr = reg_data%alr_to_i_contributor (alr)
           k_res = get_resonance_momentum (p_born, reg_data%alr_contributors(i_contr)%c)
           E_tot2 = k_res%p(0)**2
           L_to_resonance = inverse (boost (k_res, k_res**1))
           xi_max = two * space_part_norm (L_to_resonance * p_born(em)) / k_res%p(0)
        else
           E_tot2 = sqrts**2
           xi_max = two * E_em / sqrts
        end if
        log_xi_max = log (xi_max)
        associate (xi_cut => virt%settings%fks_template%xi_cut, delta_o => virt%settings%fks_template%delta_o)
          if (virt%settings%virtual_resonance_aware_collinear) then
             if (debug_active (D_VIRTUAL)) &
                  call msg_debug (D_VIRTUAL, "Using resonance-aware collinear subtraction")
             s1 = virt%gamma_p(em, i_flv)
             s2 = two * (log (sqrts / (two * E_em)) + log_xi_max) * &
                  (log (sqrts / (two * E_em)) + log_xi_max + log (virt%es_scale2 / sqrts**2)) &
                  * virt%c_flv(em, i_flv)
             s3 = two * log_xi_max * &
                  (log_xi_max - log (virt%es_scale2 / E_tot2)) * virt%c_flv(em, i_flv)
             s4 = (log (virt%es_scale2 / E_tot2) - two * log_xi_max) * virt%gamma_0(em, i_flv)
             QB(i_flv) = QB(i_flv) + (s1 + s2 + s3 + s4) * virt%sqme_born(i_flv)
          else
             if (debug_active (D_VIRTUAL)) &
                  call msg_debug (D_VIRTUAL, "Using old-fashioned collinear subtraction")
             s1 = virt%gamma_p(em, i_flv)
             s2 = log (delta_o * sqrts**2 / (two * virt%es_scale2)) * virt%gamma_0(em,i_flv)
             s3 = log (delta_o * sqrts**2 / (two * virt%es_scale2)) * two * virt%c_flv(em,i_flv) * &
                  log (two * E_em / (xi_cut * sqrts))
             ! s4 = two * virt%c_flv(em,i_flv) * (log (two * E_em / sqrts)**2 - log (xi_cut)**2)
             s4 = two * virt%c_flv(em,i_flv) * & ! a**2 - b**2 = (a - b) * (a + b), for better numerical performance
                  (log (two * E_em / sqrts) + log (xi_cut)) * (log (two * E_em / sqrts) - log (xi_cut))
             s5 = two * virt%gamma_0(em,i_flv) * log (two * E_em / sqrts)
             QB(i_flv) = QB(i_flv) + (s1 - s2 + s3 + s4 - s5) * virt%sqme_born(i_flv)
          end if
        end associate
        evaluated(i_flv, em) = .true.
     end do
   end subroutine virtual_compute_collinear_contribution
 
 @ %def virtual_compute_collinear_contribution
 @ For the massless-massive case and $i = j$ we get the massive self-eikonal of (A.10) in arXiv:0908.4272, given as
 \begin{equation}
   \mathcal{I}_{ii} = \log \frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{\beta} \log \frac{1 + \beta}{1 - \beta}.
 \end{equation}
 <<virtual: virtual: TBP>>=
   procedure :: compute_massive_self_eikonals => virtual_compute_massive_self_eikonals
 <<virtual: procedures>>=
   subroutine virtual_compute_massive_self_eikonals (virt, i_flv, &
            p_born, s_over_Q2, reg_data,  QB)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in) :: i_flv
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: s_over_Q2
     type(region_data_t), intent(in) :: reg_data
     real(default), intent(inout), dimension(:) :: QB
     integer :: i
     logical :: massive
     do i = 1, virt%n_legs
        massive = reg_data%flv_born(i_flv)%massive(i)
        if (massive) then
           QB(i_flv) = QB(i_flv) - (virt%c_flv (i, i_flv) &
                * (log (s_over_Q2) - 0.5_default * I_m_eps (p_born(i)))) &
                * virt%sqme_born (i_flv)
        end if
     end do
   end subroutine virtual_compute_massive_self_eikonals
 
 @ %def virtual_compute_massive_self_eikonals
 @ The following code implements the $\mathcal{I}_{ij}$-function.
 The complete formulas can be found in arXiv:0908.4272 (A.1-A.17) and are also discussed in arXiv:1002.2581 in Appendix A.
 The implementation may differ in the detail from the formulas presented in the above paper.
 The parameter $\xi_{\text{cut}}$ is unphysically and cancels with appropriate factors in the real subtraction.
 We keep the additional parameter for debug usage.
 The implemented formulas are then defined as follows:
 \begin{itemize}
 \item[massless-massless case]
   $p^2 = 0, k^2 = 0,$
   \begin{equation}
     \begin{split}
     \mathcal{I}_{ij} &= \frac{1}{2}\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} + \log\frac{\xi^2_{\text{cut}}s}{Q^2}\log\frac{k_ik_j}{2E_iE_j} - \rm{Li}_2\left(\frac{k_ik_j}{2E_iE_j}\right) \\
                      &+ \frac{1}{2}\log^2\frac{k_ik_j}{2E_iE_j} - \log\left(1-\frac{k_ik_j}{2E_iE_j}\right) \log\frac{k_ik_j}{2E_iE_j}.
     \end{split}
     \label{I_00}
   \end{equation}
 \item[massive-massive case]
   $p^2 \neq 0, k^2 \neq 0,$
   \begin{equation}
      \mathcal{I}_{ij} = \frac{1}{2}I_0(k_i, k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j)
      \label{I_mm}
   \end{equation}
   with
   \begin{equation}
     I_0(k_i, k_j) = \frac{1}{\beta}\log\frac{1+\beta}{1-\beta}, \qquad \beta = \sqrt{1-\frac{k_i^2k_j^2}{(k_i \cdot k_j)^2}}
   \end{equation}
   and a rather involved expression for $I_\epsilon$:
   \begin{align}
     \allowdisplaybreaks
     I_\epsilon(k_i, k_j) &= \left(K(z_j)-K(z_i)\right) \frac{1-\vec{\beta_i}\cdot\vec{\beta_j}}{\sqrt{a(1-b)}}, \\
     \vec{\beta_i} &= \frac{\vec{k}_i}{k_i^0}, \\
     a &= \beta_i^2 + \beta_j^2 - 2\vec{\beta}_i \cdot \vec{\beta}_j, \\
     x_i &= \frac{\beta_i^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a}, \\
     x_j &= \frac{\beta_j^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a} = 1-x_j, \\
     b &= \frac{\beta_i^2\beta_j^2 - (\vec{\beta}_i\cdot\vec{\beta}_j)^2}{a}, \\
     c &= \sqrt{\frac{b}{4a}}, \\
     z_+ &= \frac{1+\sqrt{1-b}}{\sqrt{b}}, \\
     z_- &= \frac{1-\sqrt{1-b}}{\sqrt{b}}, \\
     z_i &= \frac{\sqrt{x_i^2 + 4c^2} - x_i}{2c}, \\
     z_j &= \frac{\sqrt{x_j^2 + 4c^2} + x_j}{2c}, \\
     K(z) = &-\frac{1}{2}\log^2\frac{(z-z_-)(z_+-z)}{(z_++z)(z_-+z)} - 2Li_2\left(\frac{2z_-(z_+-z)}{(z_+-z_-)(z_-+z)}\right) \\
            &-2Li_2\left(-\frac{2z_+(z_-+z)}{(z_+-z_-)(z_+-z)}\right)
   \end{align}
 
 \item[massless-massive case]
   $p^2 = 0, k^2 \neq 0,$
   \begin{equation}
      \mathcal{I}_{ij} = \frac{1}{2}\left[\frac{1}{2}\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{\pi^2}{6}\right] + \frac{1}{2}I_0(k_i,k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j)
      \label{I_0m}
   \end{equation}
   with
   \begin{align}
      I_0(p,k) &= \log\frac{(\hat{p}\cdot\hat{k})^2}{\hat{k}^2}, \\
      I_\varepsilon(p,k) &= -2\left[\frac{1}{4}\log^2\frac{1-\beta}{1+\beta} + \log\frac{\hat{p}\cdot\hat{k}}{1+\beta}\log\frac{\hat{p}\cdot\hat{k}}{1-\beta} + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1+\beta}\right) + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1-\beta}\right)\right],
   \end{align}
   using
   \begin{align}
     \hat{p} = \frac{p}{p^0}, \quad \hat{k} = \frac{k}{k^0}, \quad \beta = \frac{|\vec{k}|}{k_0}, \\
     \rm{Li}_2(1 - x) + \rm{Li}_2(1 - x^{-1}) = -\frac{1}{2} \log^2 x.
   \end{align}
 
 \end{itemize}
 
 <<virtual: procedures>>=
   function compute_eikonal_factor (p_born, massive, i, j, s_o_Q2) result (I_ij)
     real(default) :: I_ij
     type(vector4_t), intent(in), dimension(:) :: p_born
     logical, dimension(:), intent(in) :: massive
     integer, intent(in) :: i, j
     real(default), intent(in) :: s_o_Q2
     if (massive(i) .and. massive(j)) then
        I_ij = compute_Imm (p_born(i), p_born(j), s_o_Q2)
     else if (.not. massive(i) .and. massive(j)) then
        I_ij = compute_I0m (p_born(i), p_born(j), s_o_Q2)
     else if (massive(i) .and. .not. massive(j)) then
        I_ij = compute_I0m (p_born(j), p_born(i), s_o_Q2)
     else
        I_ij = compute_I00 (p_born(i), p_born(j), s_o_Q2)
     end if
   end function compute_eikonal_factor
 
   function compute_I00 (pi, pj, s_o_Q2) result (I)
     type(vector4_t), intent(in) :: pi, pj
     real(default), intent(in) :: s_o_Q2
     real(default) :: I
     real(default) :: Ei, Ej
     real(default) :: pij, Eij
     real(default) :: s1, s2, s3, s4, s5
     real(default) :: arglog
     real(default), parameter :: tiny_value = epsilon(1.0)
     s1 = 0; s2 = 0; s3 = 0; s4 = 0; s5 = 0
     Ei = pi%p(0); Ej = pj%p(0)
     pij = pi * pj; Eij = Ei * Ej
     s1 = 0.5_default * log(s_o_Q2)**2
     s2 = log(s_o_Q2) * log(pij / (two * Eij))
     s3 = Li2 (pij / (two * Eij))
     s4 = 0.5_default * log (pij / (two * Eij))**2
     arglog = one - pij / (two * Eij)
     if (arglog > tiny_value) then
       s5 = log(arglog) * log(pij / (two * Eij))
     else
       s5 = zero
     end if
     I = s1 + s2 - s3 + s4 - s5
   end function compute_I00
 
   function compute_I0m (ki, kj, s_o_Q2) result (I)
     type(vector4_t), intent(in) :: ki, kj
     real(default), intent(in) :: s_o_Q2
     real(default) :: I
     real(default) :: logsomu
     real(default) :: s1, s2, s3
     s1 = 0; s2 = 0; s3 = 0
     logsomu = log(s_o_Q2)
     s1 = 0.5 * (0.5 * logsomu**2 - pi**2 / 6)
     s2 = 0.5 * I_0m_0 (ki, kj) * logsomu
     s3 = 0.5 * I_0m_eps (ki, kj)
     I = s1 + s2 - s3
   end function compute_I0m
 
   function compute_Imm (pi, pj, s_o_Q2) result (I)
     type(vector4_t), intent(in) :: pi, pj
     real(default), intent(in) :: s_o_Q2
     real(default) :: I
     real(default) :: s1, s2
     s1 = 0.5 * log(s_o_Q2) * I_mm_0(pi, pj)
     s2 = 0.5 * I_mm_eps(pi, pj)
     I = s1 - s2
   end function compute_Imm
 
   function I_m_eps (p) result (I)
     type(vector4_t), intent(in) :: p
     real(default) :: I
     real(default) :: beta
     beta = space_part_norm (p)/p%p(0)
     if (beta < tiny_07) then
        I = four * (one + beta**2/3 + beta**4/5 + beta**6/7)
     else
        I = two * log((one + beta) / (one - beta)) / beta
     end if
   end function I_m_eps
 
   function I_0m_eps (p, k) result (I)
     type(vector4_t), intent(in) :: p, k
     real(default) :: I
     type(vector4_t) :: pp, kp
     real(default) :: beta
 
     pp = p / p%p(0); kp = k / k%p(0)
 
     beta = sqrt (one - kp*kp)
     I = -2*(log((one - beta) / (one + beta))**2/4 + log((pp*kp) / (one + beta))*log((pp*kp) / (one - beta)) &
         + Li2(one - (pp*kp) / (one + beta)) + Li2(one - (pp*kp) / (one - beta)))
   end function I_0m_eps
 
   function I_0m_0 (p, k) result (I)
     type(vector4_t), intent(in) :: p, k
     real(default) :: I
     type(vector4_t) :: pp, kp
 
     pp = p / p%p(0); kp = k / k%p(0)
     I = log((pp*kp)**2 / kp**2)
   end function I_0m_0
 
   function I_mm_eps (p1, p2) result (I)
     type(vector4_t), intent(in) :: p1, p2
     real(default) :: I
     type(vector3_t) :: beta1, beta2
     real(default) :: a, b, b2
     real(default) :: zp, zm, z1, z2, x1, x2
     real(default) :: zmb, z1b
     real(default) :: K1, K2
 
     beta1 = space_part (p1) / energy(p1)
     beta2 = space_part (p2) / energy(p2)
     a = beta1**2 + beta2**2 - 2 * beta1 * beta2
     b = beta1**2 * beta2**2 - (beta1 * beta2)**2
     if (beta1**1 > beta2**1) call switch_beta (beta1, beta2)
     if (beta1 == vector3_null) then
        b2 = beta2**1
        I = (-0.5 * log ((one - b2) / (one + b2))**2 - two * Li2 (-two * b2 / (one - b2))) &
            * one / sqrt (a - b)
        return
     end if
     x1 = beta1**2 - beta1 * beta2
     x2 = beta2**2 - beta1 * beta2
     zp = sqrt (a) + sqrt (a - b)
     zm = sqrt (a) - sqrt (a - b)
     zmb = one  / zp
     z1 = sqrt (x1**2 + b) - x1
     z2 = sqrt (x2**2 + b) + x2
     z1b = one / (sqrt (x1**2 + b) + x1)
     K1 = - 0.5 * log (((z1b - zmb) * (zp - z1)) / ((zp + z1) * (z1b + zmb)))**2 &
           - two * Li2 ((two * zmb * (zp - z1)) / ((zp - zm) * (zmb + z1b))) &
           - two * Li2 ((-two * zp * (zm + z1)) / ((zp - zm) * (zp - z1)))
     K2 = - 0.5 * log ((( z2 - zm) * (zp - z2)) / ((zp + z2) * (z2 + zm)))**2 &
           - two * Li2 ((two * zm * (zp - z2)) / ((zp - zm) * (zm + z2))) &
           - two * Li2 ((-two * zp * (zm + z2)) / ((zp - zm) * (zp - z2)))
     I = (K2 - K1) * (one - beta1 * beta2) / sqrt (a - b)
   contains
     subroutine switch_beta (beta1, beta2)
       type(vector3_t), intent(inout) :: beta1, beta2
       type(vector3_t) :: beta_tmp
       beta_tmp = beta1
       beta1 = beta2
       beta2 = beta_tmp
     end subroutine switch_beta
   end function I_mm_eps
 
   function I_mm_0 (k1, k2) result (I)
     type(vector4_t), intent(in) :: k1, k2
     real(default) :: I
     real(default) :: beta
     beta = sqrt (one - k1**2 * k2**2 / (k1 * k2)**2)
     I = log ((one + beta) / (one - beta)) / beta
   end function I_mm_0
 
 @ %def I_mm_0
 @
 <<virtual: virtual: TBP>>=
   procedure :: final => virtual_final
 <<virtual: procedures>>=
   subroutine virtual_final (virtual)
     class(virtual_t), intent(inout) :: virtual
     if (allocated (virtual%gamma_0)) deallocate (virtual%gamma_0)
     if (allocated (virtual%gamma_p)) deallocate (virtual%gamma_p)
     if (allocated (virtual%c_flv)) deallocate (virtual%c_flv)
     if (allocated (virtual%n_is_neutrinos)) deallocate (virtual%n_is_neutrinos)
   end subroutine virtual_final
 
 @ %def virtual_final
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Real Subtraction}
 <<[[real_subtraction.f90]]>>=
 <<File header>>
 
 module real_subtraction
 
 <<Use kinds with double>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use format_defs, only: FMT_15
   use string_utils
   use constants
   use numeric_utils
   use diagnostics
   use pdg_arrays
   use models
   use physics_defs
   use sm_physics
   use lorentz
   use flavors
   use phs_fks, only: real_kinematics_t, isr_kinematics_t
   use phs_fks, only: I_PLUS, I_MINUS
   use phs_fks, only: SQRTS_VAR, SQRTS_FIXED
   use phs_fks, only: phs_point_set_t
   use ttv_formfactors, only: m1s_to_mpole
 
   use fks_regions
   use nlo_data
 
 <<Standard module head>>
 
 <<real subtraction: public>>
 
 <<real subtraction: parameters>>
 
 <<real subtraction: types>>
 
 <<real subtraction: interfaces>>
 
 contains
 
 <<real subtraction: procedures>>
 
 end module real_subtraction
 @ %def real_subtraction
 @
 \subsubsection{Soft subtraction terms}
 <<real subtraction: parameters>>=
   integer, parameter, public :: INTEGRATION = 0
   integer, parameter, public :: FIXED_ORDER_EVENTS = 1
   integer, parameter, public :: POWHEG = 2
 
 @ %def real subtraction parameters
 @
 <<real subtraction: public>>=
   public :: this_purpose
 <<real subtraction: procedures>>=
   function this_purpose (purpose)
     type(string_t) :: this_purpose
     integer, intent(in) :: purpose
     select case (purpose)
     case (INTEGRATION)
        this_purpose = var_str ("Integration")
     case (FIXED_ORDER_EVENTS)
        this_purpose = var_str ("Fixed order NLO events")
     case (POWHEG)
        this_purpose = var_str ("Powheg events")
     case default
        this_purpose = var_str ("Undefined!")
     end select
   end function this_purpose
 
 @ %def this_purpose
 @
 In the soft limit, the real matrix element behaves as
 \begin{equation*}
   \mathcal{R}_{\rm{soft}} = 4\pi\alpha_s \left[\sum_{i \neq j}
   \mathcal{B}_{ij} \frac{k_i \cdot k_j}{(k_i \cdot k)(k_j \cdot k)}
    - \mathcal{B} \sum_{i} \frac{k_i^2}{(k_i \cdot k)^2}C_i\right],
 \end{equation*}
 where $k$ denotes the momentum of the emitted parton. The quantity $\mathcal{B}_{ij}$ is called the color-correlated Born matrix element defined as
 \begin{equation*}
   \mathcal{B}_{ij} = \frac{1}{2s} \sum_{\stackrel{colors}{spins}} \mathcal{M}_{\{c_k\}}\left(\mathcal{M}^\dagger_{\{c_k\}}\right)_{\stackrel{c_i \rightarrow c_i'}{c_j \rightarrow c_j'}} T^a_{c_i,c_i'} T^a_{c_j,c_j'}.
 \end{equation*}
 <<real subtraction: types>>=
   type :: soft_subtraction_t
     type(region_data_t), pointer :: reg_data => null ()
     real(default), dimension(:,:), allocatable :: momentum_matrix
     logical :: use_resonance_mappings = .false.
     type(vector4_t) :: p_soft = vector4_null
     logical :: use_internal_color_correlations = .true.
     logical :: use_internal_spin_correlations = .false.
     logical :: xi2_expanded = .true.
     integer :: factorization_mode = NO_FACTORIZATION
   contains
   <<real subtraction: soft sub: TBP>>
   end type soft_subtraction_t
 
 @ %def soft_subtraction_t
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: init => soft_subtraction_init
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_init (sub_soft, reg_data)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(region_data_t), intent(in), target :: reg_data
     sub_soft%reg_data => reg_data
     allocate (sub_soft%momentum_matrix (reg_data%n_legs_born, &
          reg_data%n_legs_born))
   end subroutine soft_subtraction_init
 
 @ %def soft_subtraction_init
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: requires_boost => soft_subtraction_requires_boost
 <<real subtraction: procedures>>=
   function soft_subtraction_requires_boost (sub_soft, sqrts) result (requires_boost)
     logical :: requires_boost
     class(soft_subtraction_t), intent(in) :: sub_soft
     real(default), intent(in) :: sqrts
     real(default) :: mtop
     logical :: above_threshold
     if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then
        mtop = m1s_to_mpole (sqrts)
        above_threshold = sqrts**2 - four * mtop**2 > zero
     else
        above_threshold = .false.
     end if
     requires_boost = sub_soft%use_resonance_mappings .or. above_threshold
   end function soft_subtraction_requires_boost
 
 @ %def soft_subtraction_requires_boost
 @ The treatment of the momentum $k$ follows the discussion about the
 soft limit of the partition functions (see [1002.2581], p. 29 and
 C. Weiss' PhD Thesis, p. 24).  The parton momentum is
 pulled out, $k = E \hat{k}$. In fact, we will substitute $\hat{k}$ for
 $k$ throughout the code, because the energy will factor out of the
 equation when the soft $\mathcal{S}$-function is multiplied.  The
 momentum [[p_soft]] represents the soft limit of the radiated particle
 divided by its energy. It is a unit vector, because
 $k^2 = \left(k^0\right)^2 - \left(k^0\right)^2\hat{\vec{k}}^2 = 0$.
 
 The soft momentum is constructed by first creating a unit vector
 parallel to the emitter's Born momentum. This unit vector is then
 rotated about the corresponding angles $y$ and $\phi$ to match
 the direction of the real radiation in the soft limit.
 <<real subtraction: soft sub: TBP>>=
   procedure :: create_softvec_fsr => soft_subtraction_create_softvec_fsr
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_create_softvec_fsr &
      (sub_soft, p_born, y, phi, emitter, xi_ref_momentum)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: y, phi
     integer, intent(in) :: emitter
     type(vector4_t), intent(in) :: xi_ref_momentum
     type(vector3_t) :: dir
     type(vector4_t) :: p_em
     type(lorentz_transformation_t) :: rot
     type(lorentz_transformation_t) :: boost_to_rest_frame
     logical :: requires_boost
     associate (p_soft => sub_soft%p_soft)
        p_soft%p(0) = one
        requires_boost = sub_soft%requires_boost (two * p_born(1)%p(0))
        if (requires_boost) then
           boost_to_rest_frame = inverse (boost (xi_ref_momentum, xi_ref_momentum**1))
           p_em = boost_to_rest_frame * p_born(emitter)
        else
           p_em = p_born(emitter)
        end if
        p_soft%p(1:3) = p_em%p(1:3) / space_part_norm (p_em)
        dir = create_orthogonal (space_part (p_em))
        rot = rotation (y, sqrt(one - y**2), dir)
        p_soft = rot * p_soft
        if (.not. vanishes (phi)) then
          dir = space_part (p_em) / space_part_norm (p_em)
          rot = rotation (cos(phi), sin(phi), dir)
          p_soft = rot * p_soft
        end if
        if (requires_boost) p_soft = inverse (boost_to_rest_frame) * p_soft
     end associate
   end subroutine soft_subtraction_create_softvec_fsr
 
 @ %def soft_subtraction_create_softvec_fsr
 @ For initial-state emissions, the soft vector is just a unit vector
 with the same direction as the radiated particle.
 As $y$ for ISR is defined independently of the emitter, also [[p_soft]]
 is the same for all initial state emitters.
 <<real subtraction: soft sub: TBP>>=
   procedure :: create_softvec_isr => soft_subtraction_create_softvec_isr
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_create_softvec_isr (sub_soft, y, phi)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     real(default), intent(in) :: y, phi
     real(default) :: sin_theta
     sin_theta = sqrt(one - y**2)
     associate (p => sub_soft%p_soft%p)
        p(0) = one
        p(1) = sin_theta * sin(phi)
        p(2) = sin_theta * cos(phi)
        p(3) = y
     end associate
   end subroutine soft_subtraction_create_softvec_isr
 
 @ %def soft_subtraction_create_softvec_isr
 @ The soft vector for the real mismatch is basically the same as for usual FSR,
 except for the scaling with the total gluon energy. Moreover, the resulting
 vector is rotated into the frame where the 3-axis points along the direction
 of the emitter. This is necessary because in the collinear limit, the approximation
 \begin{equation*}
   k_i = \frac{k_i^0}{\bar{k}_j^0} \bar{k}_j = \frac{\xi\sqrt{s}}{2\bar{k}_j^0}\bar{k}_j
 \end{equation*}
 is used. The collinear limit is not included in the soft mismatch yet, but we keep
 the rotation for future usage here already (the performance loss is negligible).
 <<real subtraction: soft sub: TBP>>=
   procedure :: create_softvec_mismatch => &
      soft_subtraction_create_softvec_mismatch
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_create_softvec_mismatch (sub_soft, E, y, phi, p_em)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     real(default), intent(in) :: E, phi, y
     type(vector4_t), intent(in) :: p_em
     real(default) :: sin_theta
     type(lorentz_transformation_t) :: rot_em_off_3_axis
     sin_theta = sqrt (one - y**2)
     associate (p => sub_soft%p_soft%p)
        p(0) = E
        p(1) = E * sin_theta * sin(phi)
        p(2) = E * sin_theta * cos(phi)
        p(3) = E * y
     end associate
     rot_em_off_3_axis = rotation_to_2nd (3, space_part (p_em))
     sub_soft%p_soft = rot_em_off_3_axis * sub_soft%p_soft
   end subroutine soft_subtraction_create_softvec_mismatch
 
 @ %def soft_subtraction_create_softvec_mismatch
 @ Computation of the soft limit of $R_\alpha$. Note that what we are
 actually integrating (in the case of final-state radiation) is the
 quantity $f(0,y) / \xi$, where
 \begin{equation*}
   f(\xi,y) = \frac{J(\xi,y,\phi)}{\xi} \xi^2 R_\alpha.
 \end{equation*}
 $J/\xi$ is computed by the phase space generator. The additional factor
 of $\xi^{-1}$ is supplied in the [[evaluate_region_fsr]]-routine. Thus,
 we are left with a factor of $\xi^2$. A look on the expression for the
 soft limit of $R_\alpha$ below reveals that we are factoring out the gluon
 energy $E_i$ in the denominator. Therefore, we have a factor
 $\xi^2 / E_i^2 = 4 / q^2$.\\
 Note that the same routine is used also for the computation of the soft
 mismatch. There, the gluon energy is not factored out from the soft vector,
 so that we are left with the $\xi^2$-factor, which will eventually be
 cancelled out again. So, we just multiply with 1. Both cases are
 distinguished by the flag [[xi2_expanded]].
 
 Note that for the soft subtraction term, also the S functions are computed
 in the soft limit. The input momenta are thus the real momenta in the soft limit,
 i.e. the Born momenta given by [[p_born]].
 <<real subtraction: soft sub: TBP>>=
   procedure :: compute => soft_subtraction_compute
 <<real subtraction: procedures>>=
   function soft_subtraction_compute (sub_soft, p_born, &
      born_ij, y, q2, alpha_coupling, alr, emitter, i_res) result (sqme)
     real(default) :: sqme
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in), dimension(:,:) :: born_ij
     real(default), intent(in) :: y
     real(default), intent(in) :: q2, alpha_coupling
     integer, intent(in) :: alr, emitter, i_res
     real(default) :: s_alpha_soft
     real(default) :: kb
     real(default) :: xi2_factor
 
     if (.not. vector_set_is_cms (p_born, sub_soft%reg_data%n_in)) then
        call vector4_write_set (p_born, show_mass = .true., &
               check_conservation = .true.)
        call msg_fatal ("Soft subtraction: phase space point must be in CMS")
     end if
     if (debug2_active (D_SUBTRACTION)) then
        select case (char (sub_soft%reg_data%regions(alr)%nlo_correction_type))
        case ("QCD")
           print *, 'Compute soft subtraction using alpha_s = ', alpha_coupling
        case ("EW")
           print *, 'Compute soft subtraction using alpha_qed = ', alpha_coupling
        end select
     end if
 
     s_alpha_soft = sub_soft%reg_data%get_svalue_soft (p_born, &
          sub_soft%p_soft, alr, emitter, i_res)
     if (s_alpha_soft > one + tiny_07) call msg_fatal ("s_alpha_soft > 1!")
     if (debug2_active (D_SUBTRACTION)) &
          call msg_print_color ('s_alpha_soft', s_alpha_soft, COL_YELLOW)
     select case (sub_soft%factorization_mode)
     case (NO_FACTORIZATION)
        kb = sub_soft%evaluate_factorization_default (p_born, born_ij)
     case (FACTORIZATION_THRESHOLD)
        kb = sub_soft%evaluate_factorization_threshold (thr_leg(emitter), p_born, born_ij)
     end select
     if (debug_on) call msg_debug2 (D_SUBTRACTION, 'KB', kb)
     sqme = four * pi * alpha_coupling * s_alpha_soft * kb
     if (sub_soft%xi2_expanded) then
        xi2_factor = four / q2
     else
        xi2_factor = one
     end if
     if (emitter <= sub_soft%reg_data%n_in) then
        sqme = xi2_factor * (one - y**2) * sqme
     else
        sqme = xi2_factor * (one - y) * sqme
     end if
     if (sub_soft%reg_data%regions(alr)%double_fsr) sqme = sqme * two
   end function soft_subtraction_compute
 
 @ %def soft_subtraction_compute
 @ We loop over all external legs and do not take care to leave out non-colored
 ones because [[born_ij]] is constructed in such a way that it is only
 non-zero for colored entries.
 <<real subtraction: soft sub: TBP>>=
   procedure :: evaluate_factorization_default => &
      soft_subtraction_evaluate_factorization_default
 <<real subtraction: procedures>>=
   function soft_subtraction_evaluate_factorization_default &
      (sub_soft, p, born_ij) result (kb)
     real(default) :: kb
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in), dimension(:,:) :: born_ij
     integer :: i, j
     kb = zero
     call sub_soft%compute_momentum_matrix (p)
     do i = 1, size (p)
        do j = 1, size (p)
           kb = kb + sub_soft%momentum_matrix (i, j) * born_ij (i, j)
        end do
     end do
   end function soft_subtraction_evaluate_factorization_default
 
 @ %def soft_subtraction_evaluate_factorization_default
 @ We have to multiply this with $\xi^2(1-y)$. Further, when applying
 the soft $\mathcal{S}$-function, the energy of the radiated particle
 is factored out. Thus we have $\xi^2/E_{em}^2(1-y) = 4/q_0^2(1-y)$.
 Computes the quantity $\mathcal{K}_{ij} = \frac{k_i \cdot
 k_j}{(k_i\cdot k)(k_j\cdot k)}$.
 <<real subtraction: soft sub: TBP>>=
   procedure :: compute_momentum_matrix => &
        soft_subtraction_compute_momentum_matrix
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_compute_momentum_matrix &
        (sub_soft, p_born)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default) :: num, deno1, deno2
     integer :: i, j
     do i = 1, sub_soft%reg_data%n_legs_born
        do j = 1, sub_soft%reg_data%n_legs_born
           if (i <= j) then
              num = p_born(i) * p_born(j)
              deno1 = p_born(i) * sub_soft%p_soft
              deno2 = p_born(j) * sub_soft%p_soft
              sub_soft%momentum_matrix(i, j) = num / (deno1 * deno2)
           else
              !!! momentum matrix is symmetric.
             sub_soft%momentum_matrix(i, j) = sub_soft%momentum_matrix(j, i)
           end if
        end do
     end do
   end subroutine soft_subtraction_compute_momentum_matrix
 
 @ %def soft_subtraction_compute_momentum_matrx
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: evaluate_factorization_threshold => &
      soft_subtraction_evaluate_factorization_threshold
 <<real subtraction: procedures>>=
   function soft_subtraction_evaluate_factorization_threshold &
      (sub_soft, leg, p_born, born_ij) result (kb)
     real(default) :: kb
     class(soft_subtraction_t), intent(inout) :: sub_soft
     integer, intent(in) :: leg
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in), dimension(:,:) :: born_ij
     type(vector4_t), dimension(4) :: p
     p = get_threshold_momenta (p_born)
     kb = evaluate_leg_pair (ASSOCIATED_LEG_PAIR (leg))
     if (debug2_active (D_SUBTRACTION))  call show_debug ()
 
   contains
 
     function evaluate_leg_pair (i_start) result (kbb)
       real(default) :: kbb
       integer, intent(in) :: i_start
       integer :: i1, i2
       real(default) :: numerator, deno1, deno2
       kbb = zero
       do i1 = i_start, i_start + 1
          do i2 = i_start, i_start + 1
             numerator = p(i1) * p(i2)
             deno1 = p(i1) * sub_soft%p_soft
             deno2 = p(i2) * sub_soft%p_soft
             kbb = kbb +  numerator * born_ij (i1, i2) / deno1 / deno2
          end do
       end do
       if (debug2_active (D_SUBTRACTION)) then
          do i1 = i_start, i_start + 1
             do i2 = i_start, i_start + 1
                call msg_print_color('i1', i1, COL_PEACH)
                call msg_print_color('i2', i2, COL_PEACH)
                call msg_print_color('born_ij (i1,i2)', born_ij (i1,i2), COL_PINK)
                print *, 'Top momentum: ', p(1)%p
             end do
          end do
       end if
     end function evaluate_leg_pair
 
     subroutine show_debug ()
       integer :: i
       call msg_print_color ('soft_subtraction_evaluate_factorization_threshold', COL_GREEN)
       do i = 1, 4
          print *, 'sqrt(p(i)**2) =    ', sqrt(p(i)**2)
       end do
     end subroutine show_debug
 
   end function soft_subtraction_evaluate_factorization_threshold
 
 @ %def soft_subtraction_evaluate_factorization_threshold
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: i_xi_ref => soft_subtraction_i_xi_ref
 <<real subtraction: procedures>>=
   function soft_subtraction_i_xi_ref (sub_soft, alr, i_phs) result (i_xi_ref)
     integer :: i_xi_ref
     class(soft_subtraction_t), intent(in) :: sub_soft
     integer, intent(in) :: alr, i_phs
     if (sub_soft%use_resonance_mappings) then
        i_xi_ref = sub_soft%reg_data%alr_to_i_contributor (alr)
     else if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then
        i_xi_ref = i_phs
     else
        i_xi_ref = 1
     end if
   end function soft_subtraction_i_xi_ref
 
 @ %def soft_subtraction_i_xi_ref
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: final => soft_subtraction_final
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_final (sub_soft)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     if (associated (sub_soft%reg_data)) nullify (sub_soft%reg_data)
     if (allocated (sub_soft%momentum_matrix)) deallocate (sub_soft%momentum_matrix)
   end subroutine soft_subtraction_final
 
 @ %def soft_subtraction_final
 @
 \subsection{Soft mismatch}
 <<real subtraction: public>>=
   public :: soft_mismatch_t
 <<real subtraction: types>>=
   type :: soft_mismatch_t
     type(region_data_t), pointer :: reg_data => null ()
     real(default), dimension(:), allocatable :: sqme_born
     real(default), dimension(:,:,:), allocatable :: sqme_born_color_c
     real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c
     type(real_kinematics_t), pointer :: real_kinematics => null ()
     type(soft_subtraction_t) :: sub_soft
   contains
   <<real subtraction: soft mismatch: TBP>>
   end type soft_mismatch_t
 
 @ %def soft_mismatch_t
 @
 <<real subtraction: soft mismatch: TBP>>=
   procedure :: init => soft_mismatch_init
 <<real subtraction: procedures>>=
   subroutine soft_mismatch_init (soft_mismatch, reg_data, &
        real_kinematics, factorization_mode)
     class(soft_mismatch_t), intent(inout) :: soft_mismatch
     type(region_data_t), intent(in), target :: reg_data
     type(real_kinematics_t), intent(in), target :: real_kinematics
     integer, intent(in) :: factorization_mode
     soft_mismatch%reg_data => reg_data
     allocate (soft_mismatch%sqme_born (reg_data%n_flv_born))
     allocate (soft_mismatch%sqme_born_color_c (reg_data%n_legs_born, &
          reg_data%n_legs_born, reg_data%n_flv_born))
     allocate (soft_mismatch%sqme_born_charge_c (reg_data%n_legs_born, &
          reg_data%n_legs_born, reg_data%n_flv_born))
     call soft_mismatch%sub_soft%init (reg_data)
     soft_mismatch%sub_soft%xi2_expanded = .false.
     soft_mismatch%real_kinematics => real_kinematics
     soft_mismatch%sub_soft%factorization_mode = factorization_mode
   end subroutine soft_mismatch_init
 
 @ %def soft_mismatch_init
 @ Main routine to compute the soft mismatch. Loops over all singular regions.
 There, it first creates the soft vector, then the necessary soft real matrix element.
 These inputs are then used to get the numerical value of the soft mismatch.
 <<real subtraction: soft mismatch: TBP>>=
   procedure :: evaluate => soft_mismatch_evaluate
 <<real subtraction: procedures>>=
   function soft_mismatch_evaluate (soft_mismatch, alpha_s) result (sqme_mismatch)
     real(default) :: sqme_mismatch
     class(soft_mismatch_t), intent(inout) :: soft_mismatch
     real(default), intent(in) :: alpha_s
     integer :: alr, i_born, emitter, i_res, i_phs, i_con
     real(default) :: xi, y, q2, s
     real(default) :: E_gluon
     type(vector4_t) :: p_em
     real(default) :: sqme_alr, sqme_soft
     type(vector4_t), dimension(:), allocatable :: p_born
     sqme_mismatch = zero
     associate (real_kinematics => soft_mismatch%real_kinematics)
        xi = real_kinematics%xi_mismatch
        y = real_kinematics%y_mismatch
        s = real_kinematics%cms_energy2
        E_gluon = sqrt (s) * xi / two
 
        if (debug_active (D_MISMATCH)) then
           print *, 'Evaluating soft mismatch: '
           print *, 'Phase space: '
           call vector4_write_set (real_kinematics%p_born_cms%get_momenta(1), &
                show_mass = .true.)
           print *, 'xi: ', xi, 'y: ', y, 's: ', s, 'E_gluon: ', E_gluon
        end if
 
        allocate (p_born (soft_mismatch%reg_data%n_legs_born))
 
        do alr = 1, soft_mismatch%reg_data%n_regions
 
            i_phs = real_kinematics%alr_to_i_phs (alr)
            if (soft_mismatch%reg_data%has_pseudo_isr ()) then
               i_con = 1
               p_born = soft_mismatch%real_kinematics%p_born_onshell%get_momenta(1)
            else
               i_con = soft_mismatch%reg_data%alr_to_i_contributor (alr)
               p_born = soft_mismatch%real_kinematics%p_born_cms%get_momenta(1)
            end if
            q2 = real_kinematics%xi_ref_momenta(i_con)**2
            emitter = soft_mismatch%reg_data%regions(alr)%emitter
            p_em = p_born (emitter)
            i_res = soft_mismatch%reg_data%regions(alr)%i_res
            i_born = soft_mismatch%reg_data%regions(alr)%uborn_index
 
            call print_debug_alr ()
 
            call soft_mismatch%sub_soft%create_softvec_mismatch &
                 (E_gluon, y, real_kinematics%phi, p_em)
            if (debug_active (D_MISMATCH)) &
                 print *, 'Created soft vector: ', soft_mismatch%sub_soft%p_soft%p
 
            select type (fks_mapping => soft_mismatch%reg_data%fks_mapping)
            type is (fks_mapping_resonances_t)
               call fks_mapping%set_resonance_momentum &
                    (real_kinematics%xi_ref_momenta(i_con))
            end select
 
            sqme_soft = soft_mismatch%sub_soft%compute &
                 (p_born, soft_mismatch%sqme_born_color_c(:,:,i_born), y, &
                 q2, alpha_s, alr, emitter, i_res)
 
            sqme_alr = soft_mismatch%compute (alr, xi, y, p_em, &
                 real_kinematics%xi_ref_momenta(i_con), soft_mismatch%sub_soft%p_soft, &
                 soft_mismatch%sqme_born(i_born), sqme_soft, &
                 alpha_s, s)
 
            if (debug_on) call msg_debug (D_MISMATCH, 'sqme_alr: ', sqme_alr)
            sqme_mismatch = sqme_mismatch + sqme_alr
 
        end do
     end associate
   contains
     subroutine print_debug_alr ()
       if (debug_active (D_MISMATCH)) then
          print *, 'alr: ', alr
          print *, 'i_phs: ', i_phs, 'i_con: ', i_con, 'i_res: ', i_res
          print *, 'emitter: ', emitter, 'i_born: ', i_born
          print *, 'emitter momentum: ', p_em%p
          print *, 'resonance momentum: ', &
             soft_mismatch%real_kinematics%xi_ref_momenta(i_con)%p
          print *, 'q2: ', q2
       end if
     end subroutine print_debug_alr
   end function soft_mismatch_evaluate
 
 @ %def soft_mismatch_evaluate
 @ Computes the soft mismatch in a given $\alpha_r$,
 \begin{align*}
   I_{s+,\alpha_r} &= \int d\Phi_B \int_0^\infty d\xi \int_{-1}^1 dy \int_0^{2\pi} d\phi
      \frac{s\xi}{(4\pi)^3} \\
    &\times \left\lbrace\tilde{R}_{\alpha_r}
     \left(e^{-\frac{2k_\gamma \cdot k_{res}}{k_{res}}^2} - e^{-\xi}\right)
   - \frac{32 \pi \alpha_s C_{em}}{s\xi^2} B_{f_b(\alpha_r)} (1-y)^{-1}
     \left[e^{-\frac{2\bar{k}_{em} \cdot k_{res}}{k_{res}^2} \frac{k_\gamma^0}{k_{em}^0}} - e^{-\xi}\right]\right\rbrace.
 \end{align*}
 <<real subtraction: soft mismatch: TBP>>=
   procedure :: compute => soft_mismatch_compute
 <<real subtraction: procedures>>=
   function soft_mismatch_compute (soft_mismatch, alr, xi, y, p_em, p_res, p_soft, &
      sqme_born, sqme_soft, alpha_s, s) result (sqme_mismatch)
     real(default) :: sqme_mismatch
     class(soft_mismatch_t), intent(in) :: soft_mismatch
     integer, intent(in) :: alr
     real(default), intent(in) :: xi, y
     type(vector4_t), intent(in) :: p_em, p_res, p_soft
     real(default), intent(in) :: sqme_born, sqme_soft
     real(default), intent(in) :: alpha_s, s
     real(default) :: q2, expo, sm1, sm2, jacobian
 
     q2 = p_res**2
     expo = - two * p_soft * p_res / q2
     !!! Divide by 1 - y to factor out the corresponding
     !!! factor in the soft matrix element
     sm1 = sqme_soft / (one - y) * ( exp(expo) - exp(- xi) )
     if (debug_on) call msg_debug2 (D_MISMATCH, 'sqme_soft in mismatch ', sqme_soft)
 
     sm2 = zero
     if (soft_mismatch%reg_data%regions(alr)%has_collinear_divergence ()) then
        expo = - two * p_em * p_res / q2 * &
           p_soft%p(0) / p_em%p(0)
        sm2 = 32 * pi * alpha_s * cf / (s * xi**2) * sqme_born * &
           ( exp(expo) - exp(- xi) ) / (one - y)
     end if
 
     jacobian = soft_mismatch%real_kinematics%jac_mismatch * s * xi / (8 * twopi3)
     sqme_mismatch = (sm1 - sm2) * jacobian
 
   end function soft_mismatch_compute
 
 @ %def soft_mismatch_compute
 @
 <<real subtraction: soft mismatch: TBP>>=
   procedure :: final => soft_mismatch_final
 <<real subtraction: procedures>>=
   subroutine soft_mismatch_final (soft_mismatch)
     class(soft_mismatch_t), intent(inout) :: soft_mismatch
     call soft_mismatch%sub_soft%final ()
     if (associated (soft_mismatch%reg_data)) nullify (soft_mismatch%reg_data)
     if (allocated (soft_mismatch%sqme_born)) deallocate (soft_mismatch%sqme_born)
     if (allocated (soft_mismatch%sqme_born_color_c)) deallocate (soft_mismatch%sqme_born_color_c)
     if (allocated (soft_mismatch%sqme_born_charge_c)) deallocate (soft_mismatch%sqme_born_charge_c)
     if (associated (soft_mismatch%real_kinematics)) nullify (soft_mismatch%real_kinematics)
   end subroutine soft_mismatch_final
 
 @ %def soft_mismatch_final
 @
 \subsection{Collinear and soft-collinear subtraction terms}
 This data type deals with the calculation of the collinear and
 soft-collinear contribution to the cross section.
 <<real subtraction: public>>=
   public :: coll_subtraction_t
 <<real subtraction: types>>=
   type :: coll_subtraction_t
     integer :: n_in, n_alr
     logical :: use_resonance_mappings = .false.
     real(default) :: CA = 0, CF = 0, TR = 0
   contains
   <<real subtraction: coll sub: TBP>>
   end type coll_subtraction_t
 
 @ %def coll_subtraction_t
 @
 <<real subtraction: coll sub: TBP>>=
   procedure :: init => coll_subtraction_init
 <<real subtraction: procedures>>=
   subroutine coll_subtraction_init (coll_sub, n_alr, n_in)
     class(coll_subtraction_t), intent(inout) :: coll_sub
     integer, intent(in) :: n_alr, n_in
     coll_sub%n_in = n_in
     coll_sub%n_alr = n_alr
   end subroutine coll_subtraction_init
 
 @ %def coll_subtraction_init
 @ Set the corresponding algebra parameters of the underlying gauge group of the correction.
 <<real subtraction: coll sub: TBP>>=
   procedure :: set_parameters => coll_subtraction_set_parameters
 <<real subtraction: procedures>>=
   subroutine coll_subtraction_set_parameters (coll_sub, CA, CF, TR)
     class(coll_subtraction_t), intent(inout) :: coll_sub
     real(default), intent(in) :: CA, CF, TR
     coll_sub%CA = CA
     coll_sub%CF = CF
     coll_sub%TR = TR
   end subroutine coll_subtraction_set_parameters
 
 @ %def coll_subtraction_set_parameters
 @ This subroutine computes the collinear limit of $g^\alpha(\xi,y)$ introduced
 in eq.~\ref{fks: sub: real}. Care is given to also enable the usage for
 the soft-collinear limit. This, we write all formulas in terms of soft-finite
 quantities.
 
 We have to compute
 \begin{equation*}
   \frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]|_{y = 1}.
 \end{equation*}
 The Jacobian $J$ is proportional to $\xi$, due to the $d^3 k_{n+1} / k_{n+1}^0$ factor
 in the integration measure. It cancels the factor of $\xi$ in the denominator.
 The remaining part of the Jacobian is multiplied in [[evaluate_region_fsr]] and is
 not relevant here.
 Inserting the splitting functions exemplarily for $q \to qg$ yields
 \begin{equation*}
   g^\alpha = \frac{8\pi\alpha_s}{k_{\mathrm{em}}^2} C_F (1-y) \xi^2
              \frac{1+(1-z)^2}{z} \mathcal{B},
 \end{equation*}
 where we have chosen $z = E_\mathrm{rad} / \bar{E}_\mathrm{em}$ and $\bar{E}_\mathrm{em}$ denotes the emitter energy in the Born frame.
 The collinear final state imposes $\bar{k}_n = k_{n} + k_{n + 1}$ for the
 connection between $\Phi_n$- and $\Phi_{n+1}$-phasepace and we get $1 - z = E_\mathrm{em} / \bar{E}_\mathrm{em}$.
 The denominator can be rewritten by the constraint $\bar{k}_n^2 = (k_n +
 k_{n+1})^2 = 0$ to
 \begin{equation*}
   k_{\mathrm{em}}^2 = 2 E_\mathrm{rad} E_\mathrm{em} (1-y)
 \end{equation*}
 which cancels the $(1-y)$ factor in the numerator, thus showing that
 the whole expression is indeed collinear-finite. We can further transform
 \begin{equation*}
   E_\mathrm{rad} E_\mathrm{em} = z (1-z) \bar{E}_\mathrm{em}^2
 \end{equation*}
 so that in total we have
 \begin{equation*}
   g^\alpha = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} C_F \left(\frac{\xi}{z}\right)^2
              (1 + (1-z)^2) \mathcal{B}
 \end{equation*}
 Follow up calculations give us
 \begin{align*}
   g^{\alpha, g \rightarrow gg} & = \frac{4\pi\alpha_s}{1-z}\frac{1}{\bar{k}_{\text{em}}^2}
                                  C_{\mathrm{A}} \frac{\xi}{z} \left\lbrace 2 \left( \frac{z}{1 - z} \xi + \frac{1 - z}{\frac{z}{\xi}} \right) \mathcal{B} + 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace, \\
   g^{\alpha, g \rightarrow qq} & = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} T_{\mathrm{R}}
                                  \frac{\xi}{z} \left\lbrace \xi \mathcal{B} - 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace.
 \end{align*}
 The ratio $z / \xi$ is finite in the soft limit
 \begin{equation*}
   \frac{z}{\xi} = \frac{q^0}{2\bar{E}_\mathrm{em}}
 \end{equation*}
 so that $\xi$ does not appear explicitly in the computation.
 
 The argumentation above is valid for $q \to qg$--splittings, but the general
 factorization is valid for general splittings, also for those involving spin
 correlations and QED splittings. Note that care has to be given to the definition
 of $z$. Further, we have factored out a factor of $z$ to include in the
 ratio $z/\xi$, which has to be taken into account in the implementation of
 the splitting functions.
 <<real subtraction: coll sub: TBP>>=
   procedure :: compute_fsr => coll_subtraction_compute_fsr
 <<real subtraction: procedures>>=
   function coll_subtraction_compute_fsr &
      (coll_sub, emitter, flst, p_res, p_born, sqme_born, mom_times_sqme_spin_c, &
      xi, alpha_coupling, double_fsr) result (sqme)
     real(default) :: sqme
     class(coll_subtraction_t), intent(in) :: coll_sub
     integer, intent(in) :: emitter
     integer, dimension(:), intent(in) :: flst
     type(vector4_t), intent(in) :: p_res
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: sqme_born, mom_times_sqme_spin_c
     real(default), intent(in) :: xi, alpha_coupling
     logical, intent(in) :: double_fsr
     real(default) :: q0, z, p0, z_o_xi, onemz
     integer :: nlegs, flv_em, flv_rad
     nlegs = size (flst)
     flv_rad = flst(nlegs); flv_em = flst(emitter)
     q0 = p_res**1
     p0 = p_res * p_born(emitter) / q0
     !!! Here, z corresponds to 1-z in the formulas of arXiv:1002.2581;
     !!! the integrand is symmetric under this variable change
     z_o_xi = q0 / (two * p0)
     z = xi * z_o_xi; onemz = one - z
     if (is_gluon (flv_em) .and. is_gluon (flv_rad)) then
        sqme = coll_sub%CA * ( two * ( z / onemz * xi + onemz / z_o_xi ) * sqme_born &
             + four * xi * z * onemz * mom_times_sqme_spin_c )
     else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then
        sqme = coll_sub%TR * xi * (sqme_born - four * z * onemz * mom_times_sqme_spin_c)
     else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
        sqme = sqme_born * coll_sub%CF * (one + onemz**2) / z_o_xi
     else
        sqme = zero
     end if
     sqme = sqme / (p0**2 * onemz * z_o_xi)
     sqme = sqme * four * pi * alpha_coupling
     if (double_fsr) sqme = sqme * onemz * two
   end function coll_subtraction_compute_fsr
 
 @ %def coll_subtraction_compute_fsr
 @ Like in the context of [[coll_subtraction_compute_fsr]] we compute
 the quantity
 \begin{equation*}
   \lim_{y\to\pm1}{\left\{\frac{J(\Phi_n,\xi,y,\phi)}{\xi}
   \left[(1-y^2)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]\right\}},
 \end{equation*}
 where the $(1-y^2)$ accounts for both $y=\pm1$. Again, the Jacobian is proportional to $\xi$, so we
 drop the $J / \xi$ factor. Note that it is important to take into account this missing
 factor of $\xi$ in the computation of the Jacobian during phase-space generation
 both for fixed-beam and structure ISR. We consider only a $q \to qg$ splitting
 arguing that other splittings are identical in terms of the
 factors which cancel. It is given by
 \begin{equation*}
   g^\alpha = \frac{8\pi\alpha_s}{-k_{\mathrm{em}}^2} C_F (1-y^2) \xi^2
              \frac{1+z^2}{1-z} \mathcal{B},
 \end{equation*}
 where $g^\alpha$ is defined akin to the one for FSR in eq.~\ref{fks: sub: real}.
 Note the negative sign of $k_\mathrm{em}^2$ to compensate the negative
 virtuality of the initial-state emitter.
 For ISR, $z$ is defined with respect to the emitter energy entering the hard
 interaction, i.e.
 \begin{equation*}
   z = \frac{E_\mathrm{beam} - E_\mathrm{rad}}{E_\mathrm{beam}} =
       1 - \frac{E_\mathrm{rad}}{E_\mathrm{beam}}.
 \end{equation*}
 Because $E_\mathrm{rad} = E_\mathrm{beam} \cdot \xi$, it is
 $z = 1 - \xi$, thus one factor of $\xi$ is cancelled by $(1-z)$ in the denominator of $g^\alpha$.
 The factor $k_\mathrm{em}^2$ in the denominator is rewritten as
 \begin{equation*}
   k_\mathrm{em}^2 = \left(p_\mathrm{beam} - p_\mathrm{rad}\right)^2
                   = - 2 p_\mathrm{beam} \cdot p_\mathrm{rad}
                   = - 2 E_\mathrm{beam} E_\mathrm{rad} (1\pm y)
                   = - 2 E_\mathrm{beam}^2 (1-z) (1\pm y),
 \end{equation*}
 where we used
 \begin{equation*}
   E_\mathrm{beam} E_\mathrm{rad} = E_\mathrm{beam}^2 (1-z).
 \end{equation*}
 This leads to the cancellation of the corresponding $(1\pm y)$ factor in
 $(1-y^2)$, with the other factor becoming a simple factor of $2$, and
 the remaining factor of $\xi$ in the numerator. We thus end up with
 \begin{equation*}
   g^\alpha = \frac{8\pi\alpha_s}{E_\mathrm{beam}^2} C_F \left(1 + z^2\right)\mathcal{B},
 \end{equation*}
 which is soft-finite.
 
 Note that here in [[compute_isr]], [[sqme_born]] is supposed to be
 the squared Born matrix element convoluted with the real PDF.
 <<real subtraction: coll sub: TBP>>=
   procedure :: compute_isr => coll_subtraction_compute_isr
 <<real subtraction: procedures>>=
   function coll_subtraction_compute_isr &
      (coll_sub, emitter, flst, p_born, sqme_born, mom_times_sqme_spin_c, &
      xi, alpha_coupling, isr_mode) result (sqme)
     real(default) :: sqme
     class(coll_subtraction_t), intent(in) :: coll_sub
     integer, intent(in) :: emitter
     integer, dimension(:), intent(in) :: flst
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: sqme_born
     real(default), intent(in) :: mom_times_sqme_spin_c
     real(default), intent(in) :: xi, alpha_coupling
     integer, intent(in) :: isr_mode
     real(default) :: z, onemz, p02
     integer :: nlegs, flv_em, flv_rad
     !!! p_born must be in lab frame.
     nlegs = size (flst)
     flv_rad = flst(nlegs); flv_em = flst(emitter)
     !!! No need to pay attention to n_in = 1, because this case always has a
     !!! massive initial-state particle and thus no collinear divergence.
     p02 = p_born(1)%p(0) * p_born(2)%p(0) / two
     z = one - xi; onemz = xi
     if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then
        sqme = coll_sub%CA * (two * (z + z * onemz**2) * sqme_born + four * onemz**2 &
           / z * mom_times_sqme_spin_c)
     else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
        sqme = coll_sub%CF * (one + z**2) * sqme_born
     else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then
        sqme = coll_sub%CF * (z * onemz * sqme_born + four * onemz**2 / z * mom_times_sqme_spin_c)
     else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then
        sqme = coll_sub%TR * (z**2 + onemz**2) * onemz * sqme_born
     else
        sqme = zero
     end if
     if (isr_mode == SQRTS_VAR) then
        sqme = sqme / p02 * z
     else
        !!! We have no idea why this seems to work as there should be no factor
        !!! of z for the fixed-beam settings. This should definitely be understood in the
        !!! future!
        sqme = sqme / p02 / z
     end if
     sqme = sqme * four * pi * alpha_coupling
   end function coll_subtraction_compute_isr
 
 @ %def coll_subtraction_compute_isr
 @
 <<real subtraction: coll sub: TBP>>=
   procedure :: final => coll_subtraction_final
 <<real subtraction: procedures>>=
   subroutine coll_subtraction_final (sub_coll)
     class(coll_subtraction_t), intent(inout) :: sub_coll
     sub_coll%use_resonance_mappings = .false.
   end subroutine coll_subtraction_final
 
 @ %def coll_subtraction_final
 @
 \subsection{Real Subtraction}
 
 We store a pointer to the [[nlo_settings_t]] object which holds tuning parameters, e.g. cutoffs for the subtraction terms.
 <<real subtraction: public>>=
   public :: real_subtraction_t
 <<real subtraction: types>>=
   type :: real_subtraction_t
      type(nlo_settings_t), pointer :: settings => null ()
      type(region_data_t), pointer :: reg_data => null ()
      type(real_kinematics_t), pointer :: real_kinematics => null ()
      type(isr_kinematics_t), pointer :: isr_kinematics => null ()
      type(real_scales_t) :: scales
      real(default), dimension(:,:), allocatable :: sqme_real_non_sub
      real(default), dimension(:), allocatable :: sqme_born
      real(default), dimension(:,:), allocatable :: sf_factors
      real(default), dimension(:,:,:), allocatable :: sqme_born_color_c
      real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c
      real(default), dimension(:,:,:,:), allocatable :: sqme_born_spin_c
      type(soft_subtraction_t) :: sub_soft
      type(coll_subtraction_t) :: sub_coll
      logical, dimension(:), allocatable :: sc_required
      logical :: subtraction_deactivated = .false.
      integer :: purpose = INTEGRATION
      logical :: radiation_event = .true.
      logical :: subtraction_event = .false.
      integer, dimension(:), allocatable :: selected_alr
   contains
   <<real subtraction: real subtraction: TBP>>
   end type real_subtraction_t
 
 @ %def real_subtraction_t
 @ Initializer
 <<real subtraction: real subtraction: TBP>>=
   procedure :: init => real_subtraction_init
 <<real subtraction: procedures>>=
   subroutine real_subtraction_init (rsub, reg_data, settings)
     class(real_subtraction_t), intent(inout), target :: rsub
     type(region_data_t), intent(in), target :: reg_data
     type(nlo_settings_t), intent(in), target :: settings
     integer :: alr
     if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_init")
     if (debug_on) call msg_debug (D_SUBTRACTION, "n_in", reg_data%n_in)
     if (debug_on) call msg_debug (D_SUBTRACTION, "nlegs_born", reg_data%n_legs_born)
     if (debug_on) call msg_debug (D_SUBTRACTION, "nlegs_real", reg_data%n_legs_real)
     if (debug_on) call msg_debug (D_SUBTRACTION, "reg_data%n_regions", reg_data%n_regions)
     if (debug2_active (D_SUBTRACTION))  call reg_data%write ()
     rsub%reg_data => reg_data
     allocate (rsub%sqme_born (reg_data%n_flv_born))
     rsub%sqme_born = zero
     allocate (rsub%sf_factors (reg_data%n_regions, 0:reg_data%n_in))
     rsub%sf_factors = zero
     allocate (rsub%sqme_born_color_c (reg_data%n_legs_born, reg_data%n_legs_born, &
          reg_data%n_flv_born))
     rsub%sqme_born_color_c = zero
     allocate (rsub%sqme_born_charge_c (reg_data%n_legs_born, reg_data%n_legs_born, &
          reg_data%n_flv_born))
     rsub%sqme_born_charge_c = zero
     allocate (rsub%sqme_real_non_sub (reg_data%n_flv_real, reg_data%n_phs))
     rsub%sqme_real_non_sub = zero
     allocate (rsub%sc_required (reg_data%n_regions))
     do alr = 1, reg_data%n_regions
        rsub%sc_required(alr) = reg_data%regions(alr)%sc_required
     end do
     if (rsub%requires_spin_correlations ()) then
        allocate (rsub%sqme_born_spin_c (1:3, 1:3, reg_data%n_legs_born, reg_data%n_flv_born))
        rsub%sqme_born_spin_c = zero
     end if
     call rsub%sub_soft%init (reg_data)
     call rsub%sub_coll%init (reg_data%n_regions, reg_data%n_in)
     rsub%settings => settings
     rsub%sub_soft%use_resonance_mappings = settings%use_resonance_mappings
     rsub%sub_coll%use_resonance_mappings = settings%use_resonance_mappings
     rsub%sub_soft%factorization_mode = settings%factorization_mode
   end subroutine real_subtraction_init
 
 @ %def real_subtraction_init
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: set_real_kinematics => real_subtraction_set_real_kinematics
 <<real subtraction: procedures>>=
   subroutine real_subtraction_set_real_kinematics (rsub, real_kinematics)
     class(real_subtraction_t), intent(inout) :: rsub
     type(real_kinematics_t), intent(in), target :: real_kinematics
     rsub%real_kinematics => real_kinematics
   end subroutine real_subtraction_set_real_kinematics
 
 @ %def real_subtraction_set_real_kinematics
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: set_isr_kinematics => real_subtraction_set_isr_kinematics
 <<real subtraction: procedures>>=
   subroutine real_subtraction_set_isr_kinematics (rsub, fractions)
     class(real_subtraction_t), intent(inout) :: rsub
     type(isr_kinematics_t), intent(in), target :: fractions
     rsub%isr_kinematics => fractions
   end subroutine real_subtraction_set_isr_kinematics
 
 @ %def real_subtraction_set_isr_kinematics
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: get_i_res => real_subtraction_get_i_res
 <<real subtraction: procedures>>=
   function real_subtraction_get_i_res (rsub, alr) result (i_res)
     integer :: i_res
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr
     select type (fks_mapping => rsub%reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        i_res = fks_mapping%res_map%alr_to_i_res (alr)
     class default
        i_res = 0
     end select
   end function real_subtraction_get_i_res
 
 @ %def real_subtraction_get_i_res
 @
 \subsection{The real contribution to the cross section}
 In each singular region $\alpha$, the real contribution to $\sigma$ is
 given by the second summand of eqn. \ref{fks: sub: complete},
 \begin{equation}
   \label{fks: sub: real}
   \sigma^\alpha_{\text{real}} = \int d\Phi_n \int_0^{2\pi} d\phi
   \int_{-1}^1 dy \int_0^{\xi_{\text{max}}} d\xi
   \left(\frac{1}{\xi}\right)_+ \left(\frac{1}{1-y}\right)_+
   \underbrace{\frac{J(\Phi_n, \xi, y, \phi)}{\xi}
     \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]}_{g^\alpha(\xi,y)}.
 \end{equation}
 Writing out the plus-distribution and introducing $\tilde{\xi} =
 \xi/\xi_{\text{max}}$ to set the upper integration limit to 1,  this
 turns out to be equal to
 \begin{equation}
   \begin{split}
     \sigma^\alpha_{\rm{real}} &= \int d\Phi_n \int_0^{2\pi}d\phi
     \int_{-1}^1 \frac{dy}{1-y} \Bigg\{\int_0^1
     d\tilde{\xi}\Bigg[\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},y)}{\tilde{\xi}}
     - \underbrace{\frac{g^\alpha(0,y)}{\tilde{\xi}}}_{\text{soft}} -
     \underbrace{\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},1)}{\tilde{\xi}}}_{\text{coll.}}
     +
     \underbrace{\frac{g^\alpha(0,1)}{\tilde{\xi}}}_{\text{coll.+soft}}\Bigg]
     \\
 &+ \left[\log\xi_{\rm{max}}(y)g^\alpha(0,y) - \log\xi_{\rm{max}}(1)g^\alpha(0,1)\right]\Bigg\}.
   \end{split}
 \end{equation}
 This formula is implemented in \texttt{compute\_sqme\_real\_fin}
+
+If two or more singular regions would produce the same amplitude we only compute
+one and use the [[eqv_index]] to copy the result to the others (if [[reuse_amplitudes_fks]]
+is true).
 <<real subtraction: real subtraction: TBP>>=
   procedure :: compute => real_subtraction_compute
 <<real subtraction: procedures>>=
   subroutine real_subtraction_compute (rsub, emitter, i_phs, alpha_s, &
            alpha_qed, separate_alrs, sqme)
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: emitter, i_phs
     logical, intent(in) :: separate_alrs
     real(default), intent(inout), dimension(:) :: sqme
+    real(default), dimension(:), allocatable :: sqme_alr_arr
     real(default), intent(in) :: alpha_s, alpha_qed
     real(default) :: sqme_alr, alpha_coupling
     integer :: alr, i_con, i_res, this_emitter
     logical :: same_emitter
+    logical, dimension(:), allocatable :: alr_evaluated
+    allocate (alr_evaluated(rsub%reg_data%n_regions))
+    allocate (sqme_alr_arr(rsub%reg_data%n_regions))
+    sqme_alr_arr = zero
+    alr_evaluated = .false.
     do alr = 1, rsub%reg_data%n_regions
-       if (allocated (rsub%selected_alr)) then
-          if (.not. any (rsub%selected_alr == alr)) cycle
-       end if
-       sqme_alr = zero
-       if (emitter > rsub%isr_kinematics%n_in) then
-          same_emitter = emitter == rsub%reg_data%regions(alr)%emitter
-       else
-          same_emitter = rsub%reg_data%regions(alr)%emitter <= rsub%isr_kinematics%n_in
-       end if
-       select case (char(rsub%reg_data%regions(alr)%nlo_correction_type))
-       case ("QCD")
-          alpha_coupling = alpha_s
-       case ("EW")
-          alpha_coupling = alpha_qed
-       end select
-       if (same_emitter .and. i_phs == rsub%real_kinematics%alr_to_i_phs (alr)) then
-          i_res = rsub%get_i_res (alr)
-          this_emitter = rsub%reg_data%regions(alr)%emitter
-          sqme_alr = rsub%evaluate_emitter_region (alr, this_emitter, i_phs, i_res, &
-               alpha_coupling)
-          if (rsub%purpose == INTEGRATION .or. rsub%purpose == FIXED_ORDER_EVENTS) then
-             i_con = rsub%get_i_contributor (alr)
-             sqme_alr = sqme_alr * rsub%get_phs_factor (i_con)
+       if (.not. alr_evaluated(rsub%reg_data%regions(alr)%eqv_index)) then
+          if (allocated (rsub%selected_alr)) then
+             if (.not. any (rsub%selected_alr == alr)) cycle
+          end if
+          sqme_alr = zero
+          if (emitter > rsub%isr_kinematics%n_in) then
+             same_emitter = emitter == rsub%reg_data%regions(alr)%emitter
+          else
+             same_emitter = rsub%reg_data%regions(alr)%emitter <= rsub%isr_kinematics%n_in
           end if
+          select case (char(rsub%reg_data%regions(alr)%nlo_correction_type))
+          case ("QCD")
+             alpha_coupling = alpha_s
+          case ("EW")
+             alpha_coupling = alpha_qed
+          end select
+          if (same_emitter .and. i_phs == rsub%real_kinematics%alr_to_i_phs (alr)) then
+             i_res = rsub%get_i_res (alr)
+             this_emitter = rsub%reg_data%regions(alr)%emitter
+             sqme_alr = rsub%evaluate_emitter_region (alr, this_emitter, i_phs, i_res, &
+                  alpha_coupling)
+             if (rsub%purpose == INTEGRATION .or. rsub%purpose == FIXED_ORDER_EVENTS) then
+                i_con = rsub%get_i_contributor (alr)
+                sqme_alr = sqme_alr * rsub%get_phs_factor (i_con)
+             end if
+          end if
+          sqme_alr_arr(alr) = sqme_alr_arr(alr) + sqme_alr
+          if (.not. (debug_active (D_SUBTRACTION) .or. debug2_active (D_SUBTRACTION))) then
+             if (.not. allocated (rsub%selected_alr)) &
+                  alr_evaluated(rsub%reg_data%regions(alr)%eqv_index) = .true.
+          end if
+       else
+          sqme_alr_arr(alr) = sqme_alr_arr(rsub%reg_data%regions(alr)%eqv_index)
        end if
        if (separate_alrs) then
-          sqme(alr) = sqme(alr) + sqme_alr
+          sqme(alr) = sqme(alr) + sqme_alr_arr(alr)
        else
-          sqme(1) = sqme(1) + sqme_alr
+          sqme(1) = sqme(1) + sqme_alr_arr(alr)
        end if
     end do
     if (debug_on) then
        if (debug2_active (D_SUBTRACTION)) call check_s_alpha_consistency ()
     end if
   contains
     subroutine check_s_alpha_consistency ()
       real(default) :: sum_s_alpha, sum_s_alpha_soft
       integer :: i_ftuple
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "Check consistency of s_alpha: ")
       do alr = 1, rsub%reg_data%n_regions
          sum_s_alpha = rsub%sum_up_s_alpha(alr, i_phs)
          call msg_debug2 (D_SUBTRACTION, 'sum_s_alpha', sum_s_alpha)
          if (.not. nearly_equal(sum_s_alpha, one)) then
             call msg_bug ("The sum of all S functions should be equal to one!")
          end if
          sum_s_alpha_soft = rsub%sum_up_s_alpha_soft(alr, i_phs)
          call msg_debug2 (D_SUBTRACTION, 'sum_s_alpha_soft', sum_s_alpha_soft)
          if (.not. nearly_equal(sum_s_alpha_soft, one)) then
             call msg_bug ("The sum of all soft S functions should be equal to one!")
          end if
       end do
     end subroutine check_s_alpha_consistency
   end subroutine real_subtraction_compute
 
 @ %def real_subtraction_compute
 @ The emitter is fixed. We now have to decide whether we evaluate in ISR or FSR
 region, and also if resonances are used.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_emitter_region => real_subtraction_evaluate_emitter_region
 <<real subtraction: procedures>>=
   function real_subtraction_evaluate_emitter_region (rsub, alr, emitter, &
       i_phs, i_res, alpha_coupling) result (sqme)
     real(default) :: sqme
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     if (emitter <= rsub%isr_kinematics%n_in) then
        sqme = rsub%evaluate_region_isr (alr, emitter, i_phs, i_res, alpha_coupling)
     else
        select type (fks_mapping => rsub%reg_data%fks_mapping)
        type is (fks_mapping_resonances_t)
           call fks_mapping%set_resonance_momenta &
                (rsub%real_kinematics%xi_ref_momenta)
        end select
        sqme = rsub%evaluate_region_fsr (alr, emitter, i_phs, i_res, alpha_coupling)
     end if
   end function real_subtraction_evaluate_emitter_region
 
 @ %def real_subtraction_evaluate_emitter_region
 @ Sums up $\sum_{i_1, i_2} S_{i_1 i_2}$ for the given [[alr]].
 <<real subtraction: real subtraction: TBP>>=
   procedure :: sum_up_s_alpha => real_subtraction_sum_up_s_alpha
 <<real subtraction: procedures>>=
   function real_subtraction_sum_up_s_alpha (rsub, alr, i_phs) result (sum_s_alpha)
     real(default) :: sum_s_alpha
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, i_phs
     type(vector4_t), dimension(:), allocatable :: p_real
     integer :: i_res, i_ftuple, i1, i2
     allocate (p_real (rsub%reg_data%n_legs_real))
     if (rsub%reg_data%has_pseudo_isr ()) then
        p_real = rsub%real_kinematics%p_real_onshell(i_phs)%get_momenta (i_phs)
     else
        p_real = rsub%real_kinematics%p_real_cms%get_momenta (i_phs)
     end if
     i_res = rsub%get_i_res (alr)
     sum_s_alpha = zero
     do i_ftuple = 1, rsub%reg_data%regions(alr)%nregions
        call rsub%reg_data%regions(alr)%ftuples(i_ftuple)%get (i1, i2)
        sum_s_alpha = sum_s_alpha + rsub%reg_data%get_svalue (p_real, alr, i1, i2, i_res)
     end do
   end function real_subtraction_sum_up_s_alpha
 
 @ %def real_subtraction_sum_up_s_alpha
 @ Sums up $\sum_{i_1, i_2} S_{i_1 i_2}$ for the given [[alr]].
 The soft S functions take the real momenta in the soft limit, i.e. the Born momenta.
 For each summand of [[sum_s_alpha_soft]] we take [[p_soft]] constructed from the
 emitter of the given alpha region also for ftuples in which the first integer [[i1]]
 does not coincide with the emitter. This is necessary because only if we keep [[p_soft]]
 fixed, all soft S functions are computed with the same denominator and thus add up to 1.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: sum_up_s_alpha_soft => real_subtraction_sum_up_s_alpha_soft
 <<real subtraction: procedures>>=
   function real_subtraction_sum_up_s_alpha_soft (rsub, alr, i_phs) result (sum_s_alpha_soft)
     real(default) :: sum_s_alpha_soft
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, i_phs
     type(vector4_t), dimension(:), allocatable :: p_born
     integer :: i_res, i_ftuple, i1, i2, emitter, nlegs
     allocate (p_born (rsub%reg_data%n_legs_born))
     if (rsub%reg_data%has_pseudo_isr ()) then
        p_born = rsub%real_kinematics%p_born_onshell%get_momenta (1)
     else
        p_born = rsub%real_kinematics%p_born_cms%get_momenta (1)
     end if
     i_res = rsub%get_i_res (alr)
     emitter = rsub%reg_data%regions(alr)%emitter
     associate (r => rsub%real_kinematics)
        if (emitter > rsub%sub_soft%reg_data%n_in) then
           call rsub%sub_soft%create_softvec_fsr (p_born, r%y_soft(i_phs), r%phi, &
                emitter, r%xi_ref_momenta(rsub%sub_soft%i_xi_ref (alr, i_phs)))
        else
           call rsub%sub_soft%create_softvec_isr (r%y_soft(i_phs), r%phi)
        end if
     end associate
     nlegs = rsub%reg_data%n_legs_real
     sum_s_alpha_soft = zero
     do i_ftuple = 1, rsub%reg_data%regions(alr)%nregions
        call rsub%reg_data%regions(alr)%ftuples(i_ftuple)%get (i1, i2)
        if (i2 == nlegs) then
           sum_s_alpha_soft = sum_s_alpha_soft + rsub%reg_data%get_svalue_soft &
             (p_born, rsub%sub_soft%p_soft, alr, i1, i_res)
        end if
     end do
   end function real_subtraction_sum_up_s_alpha_soft
 
 @ %def real_subtraction_sum_up_s_alpha_soft
 @ This subroutine computes the finite part of the real matrix element in
 an individual singular region.
 First, the radiation variables are fetched and $\mathcal{R}$ is
 multiplied by the appropriate $S_\alpha$-factors,
 region multiplicities and double-FSR factors.
 Then, it computes the soft, collinear, soft-collinear and remnant matrix
 elements and supplies the corresponding factor $1/\xi/(1-y)$ as well as
 the corresponding Jacobians.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_region_fsr => real_subtraction_evaluate_region_fsr
 <<real subtraction: procedures>>=
   function real_subtraction_evaluate_region_fsr (rsub, alr, emitter, i_phs, &
        i_res, alpha_coupling) result (sqme_tot)
     real(default) :: sqme_tot
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     real(default) :: sqme_rad, sqme_soft, sqme_coll, sqme_cs, sqme_remn
     sqme_rad = zero; sqme_soft = zero; sqme_coll = zero
     sqme_cs = zero; sqme_remn = zero
     associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template)
       if (rsub%radiation_event) then
          sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs)
          call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, &
               alr, i_phs, emitter, i_res)
          call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, &
               rsub%real_kinematics, i_phs, .false., rsub%reg_data%has_pseudo_isr (), &
               emitter)
       end if
       if (rsub%subtraction_event .and. .not. rsub%subtraction_deactivated) then
          if (debug2_active (D_SUBTRACTION)) then
             print *, "[real_subtraction_evaluate_region_fsr]"
             print *, "xi: ", rsub%real_kinematics%xi_max(i_phs) * rsub%real_kinematics%xi_tilde
             print *, "y: ", rsub%real_kinematics%y(i_phs)
          end if
          call rsub%evaluate_subtraction_terms_fsr (alr, emitter, i_phs, i_res, alpha_coupling, &
               sqme_soft, sqme_coll, sqme_cs)
          call apply_kinematic_factors_subtraction_fsr (sqme_soft, sqme_coll, sqme_cs, &
               rsub%real_kinematics, i_phs)
          associate (symm_factor_fs => rsub%reg_data%born_to_real_symm_factor_fs (alr))
             sqme_soft = sqme_soft * symm_factor_fs
             sqme_coll = sqme_coll * symm_factor_fs
             sqme_cs = sqme_cs * symm_factor_fs
          end associate
          sqme_remn = compute_sqme_remnant_fsr (sqme_soft, sqme_cs, &
               rsub%real_kinematics%xi_max(i_phs), template%xi_cut, rsub%real_kinematics%xi_tilde)
          select case (rsub%purpose)
          case (INTEGRATION)
             sqme_tot = sqme_rad - sqme_soft - sqme_coll + sqme_cs + sqme_remn
          case (FIXED_ORDER_EVENTS)
             sqme_tot = - sqme_soft - sqme_coll + sqme_cs + sqme_remn
          case default
             sqme_tot = zero
             call msg_bug ("real_subtraction_evaluate_region_fsr: " // &
                  "Undefined rsub%purpose")
          end select
       else
          sqme_tot = sqme_rad
       end if
       sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand(i_phs)
       sqme_tot = sqme_tot * rsub%reg_data%regions(alr)%mult
     end associate
     if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then
        call real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad, sqme_soft, &
             sqme_coll=sqme_coll, sqme_cs=sqme_cs)
     else if (debug2_active (D_SUBTRACTION)) then
        call write_computation_status_fsr ()
     end if
   contains
   <<real subtraction: real subtraction evaluate region fsr: procedures>>
     subroutine write_computation_status_fsr (passed, total, region_type, full)
       integer, intent(in), optional :: passed, total
       character(*), intent(in), optional :: region_type
       integer :: i_born
       integer :: u
       real(default) :: xi
       logical :: yorn
       logical, intent(in), optional :: full
       yorn = .true.
       if (present (full)) yorn = full
       if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_region_fsr")
       u = given_output_unit (); if (u < 0) return
       i_born = rsub%reg_data%regions(alr)%uborn_index
       xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde
       write (u,'(A,I2)') 'rsub%purpose: ', rsub%purpose
       write (u,'(A,I4)') 'alr: ', alr
       write (u,'(A,I3)') 'emitter: ', emitter
       write (u,'(A,I3)') 'i_phs: ', i_phs
       write (u,'(A,F6.4)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs)
       write (u,'(A,F6.4)') 'xi_cut: ', rsub%real_kinematics%xi_max(i_phs) * rsub%settings%fks_template%xi_cut
       write (u,'(A,F6.4,2X,A,F6.4)') 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs)
       if (yorn) then
          write (u,'(A,ES16.9)')  'sqme_born: ', rsub%sqme_born(i_born)
          write (u,'(A,ES16.9)')  'sqme_real: ', sqme_rad
          write (u,'(A,ES16.9)')  'sqme_soft: ', sqme_soft
          write (u,'(A,ES16.9)')  'sqme_coll: ', sqme_coll
          write (u,'(A,ES16.9)')  'sqme_coll-soft: ', sqme_cs
          write (u,'(A,ES16.9)')  'sqme_remn: ', sqme_remn
          write (u,'(A,ES16.9)')  'sqme_tot: ', sqme_tot
          if (present (passed) .and. present (total) .and. &
               present (region_type)) &
               write (u,'(A)') char (str (passed) // " of " // str (total) // &
               " " // region_type // " points passed in total")
       end if
       write (u,'(A,ES16.9)')  'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1)
       write (u,'(A,ES16.9)')  'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2)
       write (u,'(A,ES16.9)')  'jacobian - coll: ', rsub%real_kinematics%jac(i_phs)%jac(3)
     end subroutine write_computation_status_fsr
   end function real_subtraction_evaluate_region_fsr
 
 @ %def real_subtraction_evalute_region_fsr
 @ Compares the real matrix element to the subtraction terms in the soft, the collinear
 or the soft-collinear limits. Used for debug purposes if [[?test_anti_coll_limit]],
 [[?test_coll_limit]] and/or [[?test_soft_limit]] are set in the Sindarin.
 [[sqme_soft]] and [[sqme_cs]] need to be provided if called for FSR and [[sqme_coll_plus]],
 [[sqme_coll_minus]], [[sqme_cs_plus]] as well as [[sqme_cs_minus]] need to be provided if called for ISR.
 <<real subtraction: procedures>>=
   subroutine real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad, sqme_soft,&
       sqme_coll, sqme_cs, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
     class(real_subtraction_t), intent(in) :: rsub
     integer, intent(in) :: alr, emitter, i_phs
     real(default), intent(in) :: sqme_rad, sqme_soft
     real(default), intent(in), optional :: sqme_coll, sqme_cs, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus
     real(default), dimension(:), allocatable, save :: sqme_rad_store
     logical :: is_soft, is_collinear_plus, is_collinear_minus, is_fsr
     real(default), parameter :: soft_threshold = 0.001_default
     real(default), parameter :: coll_threshold = 0.99_default
     real(default), parameter :: rel_smallness = 0.01_default
     real(default) :: sqme_dummy, this_sqme_rad, y, xi_tilde
     logical, dimension(:), allocatable, save :: count_alr
 
     if (.not. allocated (sqme_rad_store)) then
        allocate (sqme_rad_store (rsub%reg_data%n_regions))
        sqme_rad_store = zero
     end if
     if (rsub%radiation_event) then
        sqme_rad_store(alr) = sqme_rad
     else
        if (.not. allocated (count_alr)) then
           allocate (count_alr (rsub%reg_data%n_regions))
           count_alr = .false.
        end if
 
        if (is_gluon (rsub%reg_data%regions(alr)%flst_real%flst(rsub%reg_data%n_legs_real))) then
           xi_tilde = rsub%real_kinematics%xi_tilde
           is_soft = xi_tilde < soft_threshold
        else
           is_soft = .false.
        end if
        y = rsub%real_kinematics%y(i_phs)
        is_collinear_plus = y > coll_threshold .and. &
             rsub%reg_data%regions(alr)%has_collinear_divergence()
        is_collinear_minus = -y > coll_threshold .and. &
             rsub%reg_data%regions(alr)%has_collinear_divergence()
 
        is_fsr = emitter > rsub%isr_kinematics%n_in
 
        if (is_fsr) then
           if (.not. present(sqme_coll) .or. .not. present(sqme_cs)) &
              call msg_error ("real_subtraction_register_debug_sqme: Wrong arguments for FSR")
        else
           if (.not. present(sqme_coll_plus) .or. .not. present(sqme_coll_minus) &
                .or. .not. present(sqme_cs_plus) .or. .not. present(sqme_cs_minus)) &
              call msg_error ("real_subtraction_register_debug_sqme: Wrong arguments for ISR")
        end if
 
        this_sqme_rad = sqme_rad_store(alr)
        if (is_soft .and. .not. is_collinear_plus .and. .not. is_collinear_minus) then
           if ( .not. nearly_equal (this_sqme_rad, sqme_soft, &
                abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
              call msg_print_color (char ("Soft MEs do not match in region " // str (alr)), COL_RED)
           else
              call msg_print_color (char ("sqme_soft OK in region " // str (alr)), COL_GREEN)
           end if
           print *, 'this_sqme_rad, sqme_soft =    ', this_sqme_rad, sqme_soft
        end if
 
        if (is_collinear_plus .and. .not. is_soft) then
           if (is_fsr) then
              if ( .not. nearly_equal (this_sqme_rad, sqme_coll, &
                  abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                call msg_print_color (char ("sqme_coll OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_coll =    ', this_sqme_rad, sqme_coll
           else
              if ( .not. nearly_equal (this_sqme_rad, sqme_coll_plus, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
              call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_coll_plus OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_coll_plus =    ', this_sqme_rad, sqme_coll_plus
           end if
        end if
 
        if (is_collinear_minus .and. .not. is_soft) then
           if (.not. is_fsr) then
              if ( .not. nearly_equal (this_sqme_rad, sqme_coll_minus, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                 call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_coll_minus OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_coll_minus =    ', this_sqme_rad, sqme_coll_minus
           end if
        end if
 
        if (is_soft .and. is_collinear_plus) then
           if (is_fsr) then
              if ( .not. nearly_equal (this_sqme_rad, sqme_cs, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                 call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_cs OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_cs =    ', this_sqme_rad, sqme_cs
           else
              if ( .not. nearly_equal (this_sqme_rad, sqme_cs_plus, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                 call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_cs_plus OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_cs_plus =    ', this_sqme_rad, sqme_cs_plus
           end if
        end if
 
        if (is_soft .and. is_collinear_minus) then
           if (.not. is_fsr) then
              if ( .not. nearly_equal (this_sqme_rad, sqme_cs_minus, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                 call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_cs_minus OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_cs_minus =    ', this_sqme_rad, sqme_cs_minus
           end if
        end if
 
        count_alr (alr) = .true.
        if (all (count_alr)) then
           deallocate (count_alr)
           deallocate (sqme_rad_store)
        end if
     end if
   end subroutine real_subtraction_register_debug_sqme
 
 @ %def real_subtraction_register_debug_sqme
 @ For final state radiation, the subtraction remnant cross section is
 \begin{equation}
   \sigma_{\text{remn}} = \left(\sigma_{\text{soft}} - \sigma_{\text{soft-coll}}\right)
       \log (\xi_{\text{max}}\xi_{\text{cut}})) \cdot \tilde{\xi}.
 \end{equation}
 There is only one factor of $\log (\xi_{\text{max}}\xi_{\text{cut}})$ for both limits
 as $\xi_{\text{max}}$ does not depend on $y$ in the case of FSR.
 We use the already computed [[sqme_soft]] and [[sqme_cs]] with a factor of
 $\tilde{\xi}$ which we have to compensate.
 <<real subtraction: real subtraction evaluate region fsr: procedures>>=
   function compute_sqme_remnant_fsr (sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde) result (sqme_remn)
     real(default) :: sqme_remn
     real(default), intent(in) :: sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde
     if (debug_on) call msg_debug (D_SUBTRACTION, "compute_sqme_remnant_fsr")
     sqme_remn = (sqme_soft - sqme_cs) * log (xi_max * xi_cut) * xi_tilde
   end function compute_sqme_remnant_fsr
 
 @ %def compute_sqme_remnant_fsr
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_region_isr => real_subtraction_evaluate_region_isr
 <<real subtraction: procedures>>=
   function real_subtraction_evaluate_region_isr (rsub, alr, emitter, i_phs, i_res, alpha_coupling) &
        result (sqme_tot)
     real(default) :: sqme_tot
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     real(default) :: sqme_rad, sqme_soft, sqme_coll_plus, sqme_coll_minus
     real(default) :: sqme_cs_plus, sqme_cs_minus
     real(default) :: sqme_remn
     sqme_rad = zero; sqme_soft = zero;
     sqme_coll_plus = zero; sqme_coll_minus = zero
     sqme_cs_plus = zero; sqme_cs_minus = zero
     sqme_remn = zero
     associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template)
       if (rsub%radiation_event) then
          sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs)
          call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, &
               alr, i_phs, emitter, i_res)
          call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, rsub%real_kinematics, &
               i_phs, .true., .false.)
       end if
       if (rsub%subtraction_event .and. .not. rsub%subtraction_deactivated) then
          call rsub%evaluate_subtraction_terms_isr (alr, emitter, i_phs, i_res, alpha_coupling, &
               sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
          call apply_kinematic_factors_subtraction_isr (sqme_soft, sqme_coll_plus, &
               sqme_coll_minus, sqme_cs_plus, sqme_cs_minus, rsub%real_kinematics, i_phs)
          associate (symm_factor_fs => rsub%reg_data%born_to_real_symm_factor_fs (alr))
             sqme_soft = sqme_soft * symm_factor_fs
             sqme_coll_plus = sqme_coll_plus * symm_factor_fs
             sqme_coll_minus = sqme_coll_minus * symm_factor_fs
             sqme_cs_plus = sqme_cs_plus * symm_factor_fs
             sqme_cs_minus = sqme_cs_minus * symm_factor_fs
          end associate
          sqme_remn = compute_sqme_remnant_isr (rsub%isr_kinematics%isr_mode, &
               sqme_soft, sqme_cs_plus, sqme_cs_minus, &
               rsub%isr_kinematics, rsub%real_kinematics, i_phs, template%xi_cut)
          sqme_tot = sqme_rad - sqme_soft - sqme_coll_plus - sqme_coll_minus &
               + sqme_cs_plus + sqme_cs_minus + sqme_remn
       else
          sqme_tot = sqme_rad
       end if
     end associate
     sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand (i_phs)
     sqme_tot = sqme_tot * rsub%reg_data%regions(alr)%mult
     if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then
        call real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad,&
             sqme_soft, sqme_coll_plus=sqme_coll_plus, sqme_coll_minus=sqme_coll_minus,&
             sqme_cs_plus=sqme_cs_plus, sqme_cs_minus=sqme_cs_minus)
     else if (debug2_active (D_SUBTRACTION)) then
        call write_computation_status_isr ()
     end if
   contains
   <<real subtraction: evaluate region isr: procedures>>
     subroutine write_computation_status_isr (unit)
        integer, intent(in), optional :: unit
        integer :: i_born
        integer :: u
        real(default) :: xi
        u = given_output_unit (unit); if (u < 0) return
        i_born = rsub%reg_data%regions(alr)%uborn_index
        xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde
        write (u,'(A,I4)') 'alr: ', alr
        write (u,'(A,I2)') 'emitter: ', emitter
        write (u,'(A,F4.2)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs)
        print *, 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs)
        print *, 'xb1: ', rsub%isr_kinematics%x(1), 'xb2: ', rsub%isr_kinematics%x(2)
        print *, 'random jacobian: ', rsub%real_kinematics%jac_rand (i_phs)
        write (u,'(A,ES16.9)')  'sqme_born: ', rsub%sqme_born(i_born)
        write (u,'(A,ES16.9)')  'sqme_real: ', sqme_rad
        write (u,'(A,ES16.9)')  'sqme_soft: ', sqme_soft
        write (u,'(A,ES16.9)')  'sqme_coll_plus: ', sqme_coll_plus
        write (u,'(A,ES16.9)')  'sqme_coll_minus: ', sqme_coll_minus
        write (u,'(A,ES16.9)')  'sqme_cs_plus: ', sqme_cs_plus
        write (u,'(A,ES16.9)')  'sqme_cs_minus: ', sqme_cs_minus
        write (u,'(A,ES16.9)')  'sqme_remn: ', sqme_remn
        write (u,'(A,ES16.9)')  'sqme_tot: ', sqme_tot
        write (u,'(A,ES16.9)')  'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1)
        write (u,'(A,ES16.9)')  'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2)
        write (u,'(A,ES16.9)')  'jacobian - collplus: ', rsub%real_kinematics%jac(i_phs)%jac(3)
        write (u,'(A,ES16.9)')  'jacobian - collminus: ', rsub%real_kinematics%jac(i_phs)%jac(4)
     end subroutine write_computation_status_isr
   end function real_subtraction_evaluate_region_isr
 
 @ %def real_subtraction_evaluate_region_isr
 @ Computes the soft remnant for ISR. The formulas can be found in arXiv:1002.2581, eq. 4.21.
 and arXiv:0709.2092, sec. 5.1.2.
 This results in
 \begin{equation}
   \sigma_{\text{remn}}^{\text{ISR}} = \log(\xi_{\text{max}}(y)) \sigma_{\text{soft}}
   - \frac{1}{2} \log(\xi_{\text{max}}(1)) \sigma^{\text{soft-coll}}_{\oplus}
   - \frac{1}{2} \log(\xi_{\text{max}}(-1)) \sigma^{\text{soft-coll}}_{\ominus}
 \end{equation}
 where for ISR, $\xi_{\text{max}}$ does explicitly depend on $y$
 due to the rescaling of the $x$ values from the Born to the real partonic system 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}
 As $\xi_{\text{max}}$ is determined by the fact that the real $x_\oplus,x_\ominus$ have to
 stay in a physically meaningful regime, i.e. $x_\oplus,x_\ominus < 1$, this leads to
 \begin{align}
 \label{eqn:xi_max_isr}
 \xi_\text{max} = 1 - \text{max}
   &\left\{\frac{2(1+y)\overline{x}_\oplus^2}{\sqrt{(1+\overline{x}_\oplus^2)^2(1-y)^2 + 16y\overline{x}_\oplus^2} + (1-y)(1-\overline{x}_\oplus^2)}\right., \\
   &\left.\frac{2(1-y)\overline{x}_\oplus^2}{\sqrt{(1+\overline{x}_\oplus^2)^2(1+y)^2 - 16y\overline{x}_\oplus^2} + (1+y)(1-\overline{x}_\oplus^2)}\right\}
 \end{align}
 and thus
 \begin{align}
   \xi_{\text{max}}(y=1) &= 1 - \overline{x}_\oplus \\
   \xi_{\text{max}}(y=-1) &= 1 - \overline{x}_\ominus
 \end{align}
 So we need to use the unrescaled $\overline{x}_\oplus,\overline{x}_\ominus$ here.
 Factors of $\frac{1}{2}$ and $\frac{1}{\tilde{\xi}}$
 are already included in the matrix elements from [[apply_kinematic_factors_subtraction_isr]].
 We keep the former and remove the latter by multiplying with $\tilde{\xi}$.
 <<real subtraction: evaluate region isr: procedures>>=
   function compute_sqme_remnant_isr (isr_mode, sqme_soft, sqme_cs_plus, sqme_cs_minus, &
      isr_kinematics, real_kinematics, i_phs, xi_cut) result (sqme_remn)
     real(default) :: sqme_remn
     integer, intent(in) :: isr_mode
     real(default), intent(in) :: sqme_soft, sqme_cs_plus, sqme_cs_minus
     type(isr_kinematics_t), intent(in) :: isr_kinematics
     type(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: i_phs
     real(default), intent(in) :: xi_cut
     real(default) :: xi_tilde, xi_max, xi_max_plus, xi_max_minus, xb_plus, xb_minus
     xi_max = real_kinematics%xi_max (i_phs)
     xi_tilde = real_kinematics%xi_tilde
     select case (isr_mode)
     case (SQRTS_VAR)
        xb_plus = isr_kinematics%x(I_PLUS)
        xb_minus = isr_kinematics%x(I_MINUS)
        xi_max_plus = one - xb_plus
        xi_max_minus = one - xb_minus
     case (SQRTS_FIXED)
        xi_max_plus = real_kinematics%xi_max (i_phs)
        xi_max_minus = real_kinematics%xi_max (i_phs)
     end select
     sqme_remn = log (xi_max * xi_cut) * xi_tilde * sqme_soft &
               - log (xi_max_plus * xi_cut) * xi_tilde * sqme_cs_plus &
               - log (xi_max_minus * xi_cut) * xi_tilde * sqme_cs_minus
   end function compute_sqme_remnant_isr
 
 @ %def compute_sqme_remnant_isr
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_subtraction_terms_fsr => &
        real_subtraction_evaluate_subtraction_terms_fsr
 <<real subtraction: procedures>>=
   subroutine real_subtraction_evaluate_subtraction_terms_fsr (rsub, &
        alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll, sqme_cs)
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     real(default), intent(out) :: sqme_soft, sqme_coll, sqme_cs
     if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_subtraction_terms_fsr")
     sqme_soft = zero; sqme_coll = zero; sqme_cs = zero
     associate (xi_tilde => rsub%real_kinematics%xi_tilde, &
          y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template)
       if (template%xi_cut > xi_tilde) &
            sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling)
       if (y - 1 + template%delta_o > 0) &
            sqme_coll = rsub%compute_sub_coll (alr, emitter, i_phs, alpha_coupling)
       if (template%xi_cut > xi_tilde .and. y - 1 + template%delta_o > 0) &
            sqme_cs = rsub%compute_sub_coll_soft (alr, emitter, i_phs, alpha_coupling)
       if (debug2_active (D_SUBTRACTION)) then
          print *, "FSR Cutoff:"
          print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")"
          print *, "sub_coll: ", (y - 1 + template%delta_o) > 0, "(ME: ", sqme_coll, ")"
          print *, "sub_coll_soft: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_o) > 0, &
               "(ME: ", sqme_cs, ")"
       end if
     end associate
   end subroutine real_subtraction_evaluate_subtraction_terms_fsr
 
 @ %def real_subtraction_evaluate_subtraction_terms_fsr
 @
 <<real subtraction: procedures>>=
   subroutine evaluate_fks_factors (sqme, reg_data, real_kinematics, &
       alr, i_phs, emitter, i_res)
     real(default), intent(inout) :: sqme
     type(region_data_t), intent(inout) :: reg_data
     type(real_kinematics_t), intent(in), target :: real_kinematics
     integer, intent(in) :: alr, i_phs, emitter, i_res
     real(default) :: s_alpha
     type(phs_point_set_t), pointer :: p_real => null ()
     if (reg_data%has_pseudo_isr ()) then
        p_real => real_kinematics%p_real_onshell (i_phs)
     else
        p_real => real_kinematics%p_real_cms
     end if
     s_alpha = reg_data%get_svalue (p_real%get_momenta(i_phs), alr, emitter, i_res)
     if (debug2_active (D_SUBTRACTION)) call msg_print_color('s_alpha', s_alpha, COL_YELLOW)
     if (s_alpha > one + tiny_07) call msg_fatal ("s_alpha > 1!")
     sqme = sqme * s_alpha
     associate (region => reg_data%regions(alr))
        if (emitter > reg_data%n_in) then
           if (debug2_active (D_SUBTRACTION)) &
                print *, 'Double FSR: ', region%double_fsr_factor (p_real%get_momenta(i_phs))
           sqme = sqme * region%double_fsr_factor (p_real%get_momenta(i_phs))
        end if
     end associate
   end subroutine evaluate_fks_factors
 
 @ %def evaluate_fks_factors
 @
 <<real subtraction: procedures>>=
   subroutine apply_kinematic_factors_radiation (sqme, purpose, real_kinematics, &
          i_phs, isr, threshold, emitter)
     real(default), intent(inout) :: sqme
     integer, intent(in) :: purpose
     type(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: i_phs
     logical, intent(in) :: isr, threshold
     integer, intent(in), optional :: emitter
     real(default) :: xi, xi_tilde, s
     xi_tilde = real_kinematics%xi_tilde
     xi = xi_tilde * real_kinematics%xi_max (i_phs)
     select case (purpose)
     case (INTEGRATION, FIXED_ORDER_EVENTS)
        sqme = sqme * xi**2 / xi_tilde * real_kinematics%jac(i_phs)%jac(1)
     case (POWHEG)
        if (.not. isr) then
           s = real_kinematics%cms_energy2
           sqme = sqme * real_kinematics%jac(i_phs)%jac(1) * s / (8 * twopi3) * xi
        else
           call msg_fatal ("POWHEG with initial-state radiation not implemented yet")
        end if
     end select
   end subroutine apply_kinematic_factors_radiation
 
 @ %def apply_kinematics_factors_radiation
 @ This routine applies the factors in the integrand of eq. 4.20
 in arXiv:1002.2581 to the matrix elements.
 <<real subtraction: procedures>>=
   subroutine apply_kinematic_factors_subtraction_fsr &
      (sqme_soft, sqme_coll, sqme_cs, real_kinematics, i_phs)
     real(default), intent(inout) :: sqme_soft, sqme_coll, sqme_cs
     type(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: i_phs
     real(default) :: xi_tilde, onemy
     xi_tilde = real_kinematics%xi_tilde
     onemy = one - real_kinematics%y(i_phs)
     sqme_soft = sqme_soft / onemy / xi_tilde
     sqme_coll = sqme_coll / onemy / xi_tilde
     sqme_cs = sqme_cs / onemy / xi_tilde
     associate (jac => real_kinematics%jac(i_phs)%jac)
        sqme_soft = sqme_soft * jac(2)
        sqme_coll = sqme_coll * jac(3)
        sqme_cs = sqme_cs * jac(2)
     end associate
   end subroutine apply_kinematic_factors_subtraction_fsr
 
 @ %def apply_kinematic_factors_subtraction_fsr
 @ This routine applies the factors in the integrand of eq. 4.21
 in arXiv:1002.2581 to the matrix elements.
 <<real subtraction: procedures>>=
   subroutine apply_kinematic_factors_subtraction_isr &
      (sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, &
       sqme_cs_minus, real_kinematics, i_phs)
     real(default), intent(inout) :: sqme_soft, sqme_coll_plus, sqme_coll_minus
     real(default), intent(inout) :: sqme_cs_plus, sqme_cs_minus
     type(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: i_phs
     real(default) :: xi_tilde, y, onemy, onepy
     xi_tilde = real_kinematics%xi_tilde
     y = real_kinematics%y (i_phs)
     onemy = one - y; onepy = one + y
     associate (jac => real_kinematics%jac(i_phs)%jac)
        sqme_soft = sqme_soft / (one - y**2) / xi_tilde * jac(2)
        sqme_coll_plus = sqme_coll_plus / onemy / xi_tilde / two * jac(3)
        sqme_coll_minus = sqme_coll_minus / onepy / xi_tilde / two * jac(4)
        sqme_cs_plus = sqme_cs_plus / onemy / xi_tilde / two * jac(2)
        sqme_cs_minus = sqme_cs_minus / onepy / xi_tilde / two * jac(2)
     end associate
   end subroutine apply_kinematic_factors_subtraction_isr
 
 @ %def apply_kinematic_factors_subtraction_isr
 @ This subroutine evaluates the soft and collinear subtraction terms for ISR.
 References:
 \begin{itemize}
   \item arXiv:0709.2092, sec. 2.4.2
   \item arXiv:0908.4272, sec. 4.2
 \end{itemize}
 For the collinear terms, the procedure is as follows:
 
 If the emitter is 0, then a gluon was radiated from one of the incoming partons.
 Gluon emissions require two counter terms:
 One for emission in the direction of the first incoming parton $\oplus$
 and a second for emission in the direction of the second incoming parton $\ominus$
 because in both cases, there are divergent diagrams contributing to the matrix element.
 So in this case both, [[sqme_coll_plus]] and [[sqme_coll_minus]], are non-zero.
 
 If the emitter is 1 or 2, then a quark was emitted instead of a gluon.
 This only leads to a divergence collinear to the emitter because for anti-collinear
 quark emission, there are simply no divergent diagrams in the same region as two
 collinear quarks that cannot originate in the same splitting are non-divergent.
 This means that in case the emitter is 1, we need non-zero [[sqme_coll_plus]]
 and in case the emitter is 2, we need non-zero [[sqme_coll_minus]].
 
 At this point, we want to remind ourselves that in case of initial state divergences,
 $y$ is just the polar angle, so the [[sqme_coll_minus]] terms are there to counter emissions in
 the direction of the second incoming parton $\ominus$ and \textbf{not} to counter in general
 anti-collinear divergences.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_subtraction_terms_isr => &
       real_subtraction_evaluate_subtraction_terms_isr
 <<real subtraction: procedures>>=
   subroutine real_subtraction_evaluate_subtraction_terms_isr (rsub, &
       alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll_plus, &
       sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     real(default), intent(out) :: sqme_soft
     real(default), intent(out) :: sqme_coll_plus, sqme_coll_minus
     real(default), intent(out) :: sqme_cs_plus, sqme_cs_minus
     sqme_coll_plus = zero; sqme_cs_plus = zero
     sqme_coll_minus = zero; sqme_cs_minus = zero
     associate (xi_tilde => rsub%real_kinematics%xi_tilde, &
          y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template)
       if (template%xi_cut > xi_tilde) &
            sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling)
       if (emitter /= 2) then
          if (y - 1 + template%delta_i > 0) then
             sqme_coll_plus = rsub%compute_sub_coll (alr, 1, i_phs, alpha_coupling)
             if (template%xi_cut > xi_tilde) then
                sqme_cs_plus = rsub%compute_sub_coll_soft (alr, 1, i_phs, alpha_coupling)
             end if
          end if
       end if
       if (emitter /= 1) then
          if (-y - 1 + template%delta_i > 0) then
             sqme_coll_minus = rsub%compute_sub_coll (alr, 2, i_phs, alpha_coupling)
             if (template%xi_cut > xi_tilde) then
                sqme_cs_minus = rsub%compute_sub_coll_soft (alr, 2, i_phs, alpha_coupling)
             end if
          end if
       end if
       if (debug2_active (D_SUBTRACTION)) then
          print *, "ISR Cutoff:"
          print *, "y: ", y
          print *, "delta_i: ", template%delta_i
          print *, "emitter: ", emitter
          print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")"
          print *, "sub_coll_plus: ", (y - 1 + template%delta_i) > 0, "(ME: ", sqme_coll_plus, ")"
          print *, "sub_coll_minus: ", (-y - 1 + template%delta_i) > 0, "(ME: ", sqme_coll_minus, ")"
          print *, "sub_coll_soft_plus: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_i) > 0, &
               "(ME: ", sqme_cs_plus, ")"
          print *, "sub_coll_soft_minus: ", template%xi_cut > xi_tilde .and. (-y - 1 + template%delta_i) > 0, &
               "(ME: ", sqme_cs_minus, ")"
       end if
     end associate
   end subroutine real_subtraction_evaluate_subtraction_terms_isr
 
 @ %def real_subtraction_evaluate_subtraction_terms_isr
 @ This is basically the global part of the real Jacobian corresponding to
 \begin{equation*}
   \frac{q^2}{8 (2\pi)^3}.
 \end{equation*}
 We interpret it as the additional phase space factor of the real component,
 to be more consistent with the evaluation of the Born phase space.
 
 We specifically use the Born center-of-mass energy here.
 The real center-of-mass energy is only different from the Born center-of-mass
 energy in case of ISR. The missing factor $\frac{1}{1 - \xi}$ for this
 conversion is supplied in [[apply_kinematic_factors_radiation]] and
 [[phs_fks_generator_generate_isr]].
 <<real subtraction: real subtraction: TBP>>=
   procedure :: get_phs_factor => real_subtraction_get_phs_factor
 <<real subtraction: procedures>>=
   function real_subtraction_get_phs_factor (rsub, i_con) result (factor)
     real(default) :: factor
     class(real_subtraction_t), intent(in) :: rsub
     integer, intent(in) :: i_con
     real(default) :: s
     s = rsub%real_kinematics%xi_ref_momenta (i_con)**2
     factor = s / (8 * twopi3)
   end function real_subtraction_get_phs_factor
 
 @ %def real_subtraction_get_phs_factor
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: get_i_contributor => real_subtraction_get_i_contributor
 <<real subtraction: procedures>>=
   function real_subtraction_get_i_contributor (rsub, alr) result (i_con)
     integer :: i_con
     class(real_subtraction_t), intent(in) :: rsub
     integer, intent(in) :: alr
     if (allocated (rsub%reg_data%alr_to_i_contributor)) then
        i_con = rsub%reg_data%alr_to_i_contributor (alr)
     else
        i_con = 1
     end if
   end function real_subtraction_get_i_contributor
 
 @ %def real_subtraction_get_i_contributor
 @ Computes the soft subtraction term.
 If there is an initial state emission having a soft divergence, then a gluon
 has to have been emitted. A gluon can always be emitted from both IS partons
 and thus, we can take the [[sf_factor]] for emitter $0$ in this case.
 Be aware that this approach will not work for $pe$ collisions.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: compute_sub_soft => real_subtraction_compute_sub_soft
 <<real subtraction: procedures>>=
   function real_subtraction_compute_sub_soft (rsub, alr, emitter, &
        i_phs, i_res, alpha_coupling) result (sqme_soft)
     real(default) :: sqme_soft
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     integer :: i_xi_ref, i_born
     real(default) :: q2, sf_factor
     type(vector4_t), dimension(:), allocatable :: p_born
     associate (real_kinematics => rsub%real_kinematics, &
             nlo_corr_type => rsub%reg_data%regions(alr)%nlo_correction_type, &
             sregion => rsub%reg_data%regions(alr))
       sqme_soft = zero
       if (sregion%has_soft_divergence ()) then
          i_xi_ref = rsub%sub_soft%i_xi_ref (alr, i_phs)
          q2 = real_kinematics%xi_ref_momenta (i_xi_ref)**2
          allocate (p_born (rsub%reg_data%n_legs_born))
          if (rsub%reg_data%has_pseudo_isr ()) then
             p_born = real_kinematics%p_born_onshell%get_momenta (1)
          else
             p_born = real_kinematics%p_born_cms%get_momenta (1)
          end if
          if (emitter > rsub%sub_soft%reg_data%n_in) then
             call rsub%sub_soft%create_softvec_fsr &
                  (p_born, real_kinematics%y_soft(i_phs), &
                  real_kinematics%phi, emitter, &
                  real_kinematics%xi_ref_momenta(i_xi_ref))
             sf_factor = one
          else
             call rsub%sub_soft%create_softvec_isr &
                  (real_kinematics%y_soft(i_phs), real_kinematics%phi)
             sf_factor = rsub%sf_factors(alr, 0)
          end if
          i_born = sregion%uborn_index
          select case (char (nlo_corr_type))
          case ("QCD")
             sqme_soft = rsub%sub_soft%compute &
             (p_born, rsub%sqme_born_color_c(:,:,i_born) * &
             sf_factor, real_kinematics%y(i_phs), &
             q2, alpha_coupling, alr, emitter, i_res)
          case ("EW")
             sqme_soft = rsub%sub_soft%compute &
             (p_born, rsub%sqme_born_charge_c(:,:,i_born) * &
             sf_factor, real_kinematics%y(i_phs), &
             q2, alpha_coupling, alr, emitter, i_res)
          end select
       end if
     end associate
     if (debug2_active (D_SUBTRACTION)) call check_soft_vector ()
   contains
     subroutine check_soft_vector ()
       !!! p_soft = p_gluon / E_gluon only in the soft limit
       !!! This check only has to be passed for ISR or for FSR if ?test_soft_limit = true is set.
       type(vector4_t) :: p_gluon
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "Compare soft vector: ")
       print *, 'p_soft: ', rsub%sub_soft%p_soft%p
       print *, 'Normalized gluon momentum: '
       if (rsub%reg_data%has_pseudo_isr ()) then
          p_gluon = rsub%real_kinematics%p_real_onshell(thr_leg(emitter))%get_momentum &
               (i_phs, rsub%reg_data%n_legs_real)
       else
          p_gluon = rsub%real_kinematics%p_real_cms%get_momentum &
               (i_phs, rsub%reg_data%n_legs_real)
       end if
       call vector4_write (p_gluon / p_gluon%p(0), show_mass = .true.)
     end subroutine check_soft_vector
   end function real_subtraction_compute_sub_soft
 
 @ %def real_subtraction_compute_sub_soft
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: get_spin_correlation_term => real_subtraction_get_spin_correlation_term
 <<real subtraction: procedures>>=
   function real_subtraction_get_spin_correlation_term (rsub, alr, i_born, emitter) &
         result (mom_times_sqme)
     real(default) :: mom_times_sqme
     class(real_subtraction_t), intent(in) :: rsub
     integer, intent(in) :: alr, i_born, emitter
     real(default), dimension(0:3) :: k_perp
     integer :: mu, nu
     if (rsub%sc_required(alr)) then
        if (debug2_active(D_SUBTRACTION)) call check_me_consistency ()
        associate (real_kin => rsub%real_kinematics)
          if (emitter > rsub%reg_data%n_in) then
             k_perp = real_subtraction_compute_k_perp_fsr ( &
                  real_kin%p_born_lab%get_momentum(1, emitter), &
                  rsub%real_kinematics%phi)
          else
             k_perp = real_subtraction_compute_k_perp_isr ( &
                  real_kin%p_born_lab%get_momentum(1, emitter), &
                  rsub%real_kinematics%phi)
          end if
        end associate
        mom_times_sqme = zero
        do mu = 1, 3
           do nu = 1, 3
              mom_times_sqme = mom_times_sqme + &
                   k_perp(mu) * k_perp(nu) * rsub%sqme_born_spin_c (mu, nu, emitter, i_born)
           end do
        end do
     else
        mom_times_sqme = zero
     end if
   contains
     subroutine check_me_consistency ()
       real(default) ::  sqme_sum
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "Spin-correlation: Consistency check")
       sqme_sum = rsub%sqme_born_spin_c(1,1,emitter,i_born) &
                - rsub%sqme_born_spin_c(2,2,emitter,i_born) &
                - rsub%sqme_born_spin_c(3,3,emitter,i_born)
       if (.not. nearly_equal (sqme_sum, -rsub%sqme_born(i_born), 0.0001_default)) then
          print *, 'Spin-correlated matrix elements are not consistent: '
          print *, 'emitter: ', emitter
          print *, 'g^{mu,nu} B_{mu,nu}: ', -sqme_sum
          print *, 'all Born matrix elements: ', rsub%sqme_born
          call msg_fatal ("FAIL")
       else
          call msg_print_color ("Success", COL_GREEN)
       end if
     end subroutine check_me_consistency
   end function real_subtraction_get_spin_correlation_term
 
 @ %def real_subtraction_get_spin_correlation_term
 @ Construct a normalised momentum perpendicular to momentum [[p]] and rotate by
 an arbitrary angle [[phi]]. The angular conventions we use here are
 equivalent to those used by POWHEG.
 <<real subtraction: public>>=
   public :: real_subtraction_compute_k_perp_fsr, &
        real_subtraction_compute_k_perp_isr
 <<real subtraction: procedures>>=
   function real_subtraction_compute_k_perp_fsr (p, phi) result (k_perp_fsr)
     real(default), dimension(0:3) :: k_perp_fsr
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: phi
     type(vector4_t) :: k
     type(vector3_t) :: vec
     type(lorentz_transformation_t) :: rot
     vec = p%p(1:3) / p%p(0)
     k%p(0) = zero
     k%p(1) = p%p(1); k%p(2) = p%p(2)
     k%p(3) = - (p%p(1)**2 + p%p(2)**2) / p%p(3)
     rot = rotation (cos(phi), sin(phi), vec)
     k = rot * k
     k%p(1:3) = k%p(1:3) / space_part_norm (k)
     k_perp_fsr = k%p
   end function real_subtraction_compute_k_perp_fsr
 
   function real_subtraction_compute_k_perp_isr (p, phi) result (k_perp_isr)
     real(default), dimension(0:3) :: k_perp_isr
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: phi
     k_perp_isr(0) = zero
     k_perp_isr(1) = sin(phi)
     k_perp_isr(2) = cos(phi)
     k_perp_isr(3) = zero
   end function real_subtraction_compute_k_perp_isr
 
 @ %def real_subtraction_compute_k_perp_fsr, real_subtraction_compute_k_perp_isr
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: compute_sub_coll => real_subtraction_compute_sub_coll
 <<real subtraction: procedures>>=
   function real_subtraction_compute_sub_coll (rsub, alr, em, i_phs, alpha_coupling) &
          result (sqme_coll)
     real(default) :: sqme_coll
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, em, i_phs
     real(default), intent(in) :: alpha_coupling
     real(default) :: xi, xi_max
     real(default) :: mom_times_sqme_spin_c
     integer :: i_con
     real(default) :: pfr
     associate (sregion => rsub%reg_data%regions(alr))
       sqme_coll = zero
       if (sregion%has_collinear_divergence ()) then
          xi = rsub%real_kinematics%xi_tilde * rsub%real_kinematics%xi_max(i_phs)
          if (rsub%sub_coll%use_resonance_mappings) then
             i_con = rsub%reg_data%alr_to_i_contributor (alr)
          else
             i_con = 1
          end if
          mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em)
          if (em <= rsub%sub_coll%n_in) then
             select case (rsub%isr_kinematics%isr_mode)
             case (SQRTS_FIXED)
                xi_max = rsub%real_kinematics%xi_max(i_phs)
             case (SQRTS_VAR)
                xi_max = one - rsub%isr_kinematics%x(em)
             end select
             xi = rsub%real_kinematics%xi_tilde * xi_max
             if (sregion%nlo_correction_type == "QCD") then
                call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
             else if (sregion%nlo_correction_type == "EW") then
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(em)**2, &
                     TR = sregion%flst_real%charge(size(sregion%flst_real%flst))**2)
             end if
             sqme_coll = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, &
                  rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
                  rsub%sqme_born(sregion%uborn_index) * rsub%sf_factors(alr, em), &
                  mom_times_sqme_spin_c * rsub%sf_factors(alr, em), &
                  xi, alpha_coupling, rsub%isr_kinematics%isr_mode)
          else
             if (sregion%nlo_correction_type == "QCD") then
                call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
             else if (sregion%nlo_correction_type == "EW") then
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(sregion%emitter)**2, &
                     TR = sregion%flst_real%charge(sregion%emitter)**2)
             end if
             sqme_coll = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, &
                  rsub%real_kinematics%xi_ref_momenta (i_con), &
                  rsub%real_kinematics%p_born_lab%get_momenta(1), &
                  rsub%sqme_born(sregion%uborn_index), &
                  mom_times_sqme_spin_c, &
                  xi, alpha_coupling, sregion%double_fsr)
             if (rsub%sub_coll%use_resonance_mappings) then
                select type (fks_mapping => rsub%reg_data%fks_mapping)
                type is (fks_mapping_resonances_t)
                   pfr = fks_mapping%get_resonance_weight (alr, &
                        rsub%real_kinematics%p_born_cms%get_momenta(1))
                end select
                sqme_coll = sqme_coll * pfr
             end if
          end if
       end if
     end associate
   end function real_subtraction_compute_sub_coll
 
 @ %def real_subtraction_compute_sub_coll
 @ Computes the soft-collinear subtraction term. For alpha regions with emitter
 $0$, this routine is called with [[em == 1]] and [[em == 2]] separately.
 To still be able to use the unrescaled pdf factors stored in [[sf_factors(alr, 0)]]
 in this case, we need to differentiate between [[em]] and [[em_pdf]].
 <<real subtraction: real subtraction: TBP>>=
   procedure :: compute_sub_coll_soft => real_subtraction_compute_sub_coll_soft
 <<real subtraction: procedures>>=
   function real_subtraction_compute_sub_coll_soft (rsub, alr, em, i_phs, alpha_coupling) &
        result (sqme_cs)
     real(default) :: sqme_cs
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, em, i_phs
     real(default), intent(in) :: alpha_coupling
     real(default) :: mom_times_sqme_spin_c
     integer :: i_con, em_pdf
     associate (sregion => rsub%reg_data%regions(alr))
       sqme_cs = zero
       if (sregion%has_collinear_divergence ()) then
          if (rsub%sub_coll%use_resonance_mappings) then
             i_con = rsub%reg_data%alr_to_i_contributor (alr)
          else
             i_con = 1
          end if
          mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em)
          if (em <= rsub%sub_coll%n_in) then
             em_pdf = sregion%emitter
             if (sregion%nlo_correction_type == "QCD") then
                call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
             else if (sregion%nlo_correction_type == "EW") then
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(em)**2, &
                     TR = sregion%flst_real%charge(size(sregion%flst_real%flst))**2)
             end if
             sqme_cs = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, &
                  rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
                  rsub%sqme_born(sregion%uborn_index) * rsub%sf_factors(alr, em_pdf), &
                  mom_times_sqme_spin_c * rsub%sf_factors(alr, em_pdf), &
                  zero, alpha_coupling, rsub%isr_kinematics%isr_mode)
          else
             if (sregion%nlo_correction_type == "QCD") then
                call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
             else if (sregion%nlo_correction_type == "EW") then
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(sregion%emitter)**2, &
                     TR = sregion%flst_real%charge(sregion%emitter)**2)
             end if
             sqme_cs = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, &
                  rsub%real_kinematics%xi_ref_momenta(i_con), &
                  rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
                  rsub%sqme_born(sregion%uborn_index), &
                  mom_times_sqme_spin_c, &
                  zero, alpha_coupling, sregion%double_fsr)
          end if
       end if
     end associate
   end function real_subtraction_compute_sub_coll_soft
 
 @ %def real_subtraction_compute_sub_coll_soft
 <<real subtraction: real subtraction: TBP>>=
   procedure :: requires_spin_correlations => &
        real_subtraction_requires_spin_correlations
 <<real subtraction: procedures>>=
   function real_subtraction_requires_spin_correlations (rsub) result (val)
     logical :: val
     class(real_subtraction_t), intent(in) :: rsub
     val = any (rsub%sc_required)
   end function real_subtraction_requires_spin_correlations
 
 @ %def real_subtraction_requires_spin_correlations
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: final => real_subtraction_final
 <<real subtraction: procedures>>=
   subroutine real_subtraction_final (rsub)
     class(real_subtraction_t), intent(inout) :: rsub
     call rsub%sub_soft%final ()
     call rsub%sub_coll%final ()
     !!! Finalization of region data is done in pcm_nlo_final
     if (associated (rsub%reg_data)) nullify (rsub%reg_data)
     !!! Finalization of real kinematics is done in pcm_instance_nlo_final
     if (associated (rsub%real_kinematics)) nullify (rsub%real_kinematics)
     if (associated (rsub%isr_kinematics)) nullify (rsub%isr_kinematics)
     if (allocated (rsub%sqme_real_non_sub)) deallocate (rsub%sqme_real_non_sub)
     if (allocated (rsub%sqme_born)) deallocate (rsub%sqme_born)
     if (allocated (rsub%sf_factors)) deallocate (rsub%sf_factors)
     if (allocated (rsub%sqme_born_color_c)) deallocate (rsub%sqme_born_color_c)
     if (allocated (rsub%sqme_born_charge_c)) deallocate (rsub%sqme_born_charge_c)
     if (allocated (rsub%sc_required)) deallocate (rsub%sc_required)
     if (allocated (rsub%selected_alr)) deallocate (rsub%selected_alr)
   end subroutine real_subtraction_final
 
 @ %def real_subtraction_final
 @ \subsubsection{Partitions of the real matrix element and Powheg damping}
 <<real subtraction: public>>=
   public :: real_partition_t
 <<real subtraction: types>>=
   type, abstract :: real_partition_t
   contains
   <<real subtraction: real partition: TBP>>
   end type real_partition_t
 
 @ %def real partition_t
 @
 <<real subtraction: real partition: TBP>>=
   procedure (real_partition_init), deferred :: init
 <<real subtraction: interfaces>>=
   abstract interface
      subroutine real_partition_init (partition, scale, reg_data)
        import
        class(real_partition_t), intent(out) :: partition
        real(default), intent(in) :: scale
        type(region_data_t), intent(in) :: reg_data
      end subroutine real_partition_init
   end interface
 
 @ %def real_partition_init
 @
 <<real subtraction: real partition: TBP>>=
   procedure (real_partition_write), deferred :: write
 <<real subtraction: interfaces>>=
   abstract interface
      subroutine real_partition_write (partition, unit)
        import
        class(real_partition_t), intent(in) :: partition
        integer, intent(in), optional :: unit
      end subroutine real_partition_write
   end interface
 
 @ %def real_partition_write
 @ To allow really arbitrary damping functions, [[get_f]] should get the
 full real phase space as argument and not just some [[pt2]] that is
 extracted higher up.
 <<real subtraction: real partition: TBP>>=
   procedure (real_partition_get_f), deferred :: get_f
 <<real subtraction: interfaces>>=
   abstract interface
     function real_partition_get_f (partition, p) result (f)
        import
        real(default) :: f
        class(real_partition_t), intent(in) :: partition
        type(vector4_t), intent(in), dimension(:) :: p
     end function real_partition_get_f
   end interface
 
 @ %def real_partition_get_f
 @
 <<real subtraction: public>>=
   public :: powheg_damping_simple_t
 <<real subtraction: types>>=
   type, extends (real_partition_t) :: powheg_damping_simple_t
      real(default) :: h2 = 5._default
      integer :: emitter
   contains
   <<real subtraction: powheg damping simple: TBP>>
   end type powheg_damping_simple_t
 
 @ %def powheg_damping_simple_t
 @
 <<real subtraction: powheg damping simple: TBP>>=
   procedure :: get_f => powheg_damping_simple_get_f
 <<real subtraction: procedures>>=
   function powheg_damping_simple_get_f (partition, p) result (f)
     real(default) :: f
     class(powheg_damping_simple_t), intent(in) :: partition
     type(vector4_t), intent(in), dimension(:) :: p
     !!! real(default) :: pt2
     f = 1
     call msg_bug ("Simple damping currently not available")
     !!! TODO (cw-2017-03-01) Compute pt2 from emitter)
     !!! f = partition%h2 / (pt2 + partition%h2)
   end function powheg_damping_simple_get_f
 
 @ %def powheg_damping_simple_get_f
 @
 <<real subtraction: powheg damping simple: TBP>>=
   procedure :: init => powheg_damping_simple_init
 <<real subtraction: procedures>>=
   subroutine powheg_damping_simple_init (partition, scale, reg_data)
     class(powheg_damping_simple_t), intent(out) :: partition
     real(default), intent(in) :: scale
     type(region_data_t), intent(in) :: reg_data
     partition%h2 = scale**2
   end subroutine powheg_damping_simple_init
 
 @ %def powheg_damping_simple_init
 @
 <<real subtraction: powheg damping simple: TBP>>=
   procedure :: write => powheg_damping_simple_write
 <<real subtraction: procedures>>=
   subroutine powheg_damping_simple_write (partition, unit)
     class(powheg_damping_simple_t), intent(in) :: partition
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(1x,A)") "Powheg damping simple: "
     write (u, "(1x,A, "// FMT_15 // ")") "scale h2: ", partition%h2
   end subroutine powheg_damping_simple_write
 
 @ %def powheg_damping_simple_write
 @
 <<real subtraction: public>>=
   public :: real_partition_fixed_order_t
 <<real subtraction: types>>=
   type, extends (real_partition_t) :: real_partition_fixed_order_t
      real(default) :: scale
      type(ftuple_t), dimension(:), allocatable :: fks_pairs
   contains
   <<real subtraction: real partition fixed order: TBP>>
   end type real_partition_fixed_order_t
 
 @ %def real_partition_fixed_order_t
 @
 <<real subtraction: real partition fixed order: TBP>>=
   procedure :: init => real_partition_fixed_order_init
 <<real subtraction: procedures>>=
   subroutine real_partition_fixed_order_init (partition, scale, reg_data)
     class(real_partition_fixed_order_t), intent(out) :: partition
     real(default), intent(in) :: scale
     type(region_data_t), intent(in) :: reg_data
   end subroutine real_partition_fixed_order_init
 
 @ %def real_partition_fixed_order_init
 @
 <<real subtraction: real partition fixed order: TBP>>=
   procedure :: write => real_partition_fixed_order_write
 <<real subtraction: procedures>>=
   subroutine real_partition_fixed_order_write (partition, unit)
     class(real_partition_fixed_order_t), intent(in) :: partition
     integer, intent(in), optional :: unit
   end subroutine real_partition_fixed_order_write
 
 @ %def real_partition_fixed_order_write
 @
 <<real subtraction: real partition fixed order: TBP>>=
   procedure :: get_f => real_partition_fixed_order_get_f
 <<real subtraction: procedures>>=
   function real_partition_fixed_order_get_f (partition, p) result (f)
     real(default) :: f
     class(real_partition_fixed_order_t), intent(in) :: partition
     type(vector4_t), intent(in), dimension(:) :: p
     integer :: i
     f = zero
     do i = 1, size (partition%fks_pairs)
        associate (ii => partition%fks_pairs(i)%ireg)
           if ((p(ii(1)) + p(ii(2)))**1 < p(ii(1))**1 + p(ii(2))**1 + partition%scale) then
              f = one
              exit
           end if
        end associate
     end do
   end function real_partition_fixed_order_get_f
 
 @ %def real_partition_fixed_order_get_f
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[real_subtraction_ut.f90]]>>=
 <<File header>>
 
 module real_subtraction_ut
   use unit_tests
   use real_subtraction_uti
 
 <<Standard module head>>
 
 <<Real subtraction: public test>>
 
 contains
 
 <<Real subtraction: test driver>>
 
 end module real_subtraction_ut
 @ %def real_subtraction_ut
 @
 <<[[real_subtraction_uti.f90]]>>=
 <<File header>>
 
 module real_subtraction_uti
 <<Use kinds>>
 
   use physics_defs
   use lorentz
   use numeric_utils
   use real_subtraction
 
 <<Standard module head>>
 
 <<Real subtraction: test declarations>>
 
 contains
 
 <<Real subtraction: tests>>
 
 end module real_subtraction_uti
 @ %def real_subtraction_ut
 @ API: driver for the unit tests below.
 <<Real subtraction: public test>>=
   public :: real_subtraction_test
 <<Real subtraction: test driver>>=
   subroutine real_subtraction_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Real subtraction: execute tests>>
   end subroutine real_subtraction_test
 
 @ %def real_subtraction_test
 @ Test the final-state collinear subtraction.
 <<Real subtraction: execute tests>>=
   call test (real_subtraction_1, "real_subtraction_1", &
        "final-state collinear subtraction", &
        u, results)
 <<Real subtraction: test declarations>>=
   public :: real_subtraction_1
 <<Real subtraction: tests>>=
   subroutine real_subtraction_1 (u)
     integer, intent(in) :: u
 
     type(coll_subtraction_t) :: coll_sub
     real(default) :: sqme_coll
     type(vector4_t) :: p_res
     type(vector4_t), dimension(5) :: p_born
     real(default), dimension(4) :: k_perp
     real(default), dimension(4,4) :: b_munu
     integer :: mu, nu
     real(default) :: born, born_c
     integer, dimension(6) :: flst
 
     p_born(1)%p = [500, 0, 0, 500]
     p_born(2)%p = [500, 0, 0, -500]
     p_born(3)%p = [3.7755E+02, 2.2716E+02, -95.4172, 2.8608E+02]
     p_born(4)%p = [4.9529E+02, -2.739E+02, 84.8535, -4.0385E+02]
     p_born(5)%p = [1.2715E+02, 46.7375, 10.5637, 1.1778E+02]
     p_res = p_born(1) + p_born(2)
     flst = [11, -11 , -2, 2, -2, 2]
 
     b_munu(1, :) = [0., 0., 0., 0.]
     b_munu(2, :) = [0., 1., 1., 1.]
     b_munu(3, :) = [0., 1., 1., 1.]
     b_munu(4, :) = [0., 1., 1., 1.]
 
     k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default)
     born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4)
     born_c = 0.
     do mu = 1, 4
        do nu = 1, 4
           born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu)
        end do
     end do
 
     write (u, "(A)") "* Test output: real_subtraction_1"
     write (u, "(A)") "*   Purpose: final-state collinear subtraction"
     write (u, "(A)")
 
     write (u, "(A, L1)") "* vanishing scalar-product of 3-momenta k_perp and p_born(emitter): ", &
          nearly_equal (dot_product (p_born(5)%p(1:3), k_perp(2:4)), 0._default)
 
     call coll_sub%init (n_alr = 1, n_in = 2)
     call coll_sub%set_parameters (CA, CF, TR)
 
     write (u, "(A)")
     write (u, "(A)") "* g -> qq splitting"
     write (u, "(A)")
 
     sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, &
          born, born_c, 0.5_default, 0.25_default, .false.)
 
     write (u, "(A,F15.12)") "ME: ", sqme_coll
 
     write (u, "(A)")
     write (u, "(A)") "* g -> gg splitting"
     write (u, "(A)")
 
     b_munu(1, :) = [0., 0., 0., 0.]
     b_munu(2, :) = [0., 0., 0., 1.]
     b_munu(3, :) = [0., 0., 1., 1.]
     b_munu(4, :) = [0., 0., 1., 1.]
 
     k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default)
     born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4)
     born_c = 0.
     do mu = 1, 4
        do nu = 1, 4
           born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu)
        end do
     end do
 
     flst = [11, -11, 2, -2, 21, 21]
     sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, &
          born, born_c, 0.5_default, 0.25_default, .true.)
 
     write (u, "(A,F15.12)") "ME: ", sqme_coll
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: real_subtraction_1"
     write (u, "(A)")
   end subroutine real_subtraction_1
 
 @ %def real_subtraction_1
 @
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Combining the FKS Pieces}
 <<[[nlo_data.f90]]>>=
 <<File header>>
 
 module nlo_data
 
 <<Use kinds>>
 <<Use strings>>
   use diagnostics
   use constants, only: zero
   use string_utils, only: split_string, read_ival, string_contains_word
   use io_units
   use lorentz
   use variables, only: var_list_t
   use format_defs, only: FMT_15
   use physics_defs, only: THR_POS_WP, THR_POS_WM
   use physics_defs, only: THR_POS_B, THR_POS_BBAR
   use physics_defs, only: NO_FACTORIZATION, FACTORIZATION_THRESHOLD
 
 <<Standard module head>>
 
 <<nlo data: public>>
 
 <<nlo data: parameters>>
 
 <<nlo data: types>>
 <<nlo data: interfaces>>
 
 contains
 
 <<nlo data: procedures>>
 
 end module nlo_data
 
 @ %def nlo_data
 @
 <<nlo data: parameters>>=
   integer, parameter, public :: FKS_DEFAULT = 1
   integer, parameter, public :: FKS_RESONANCES = 2
 
   integer, dimension(2), parameter, public :: ASSOCIATED_LEG_PAIR = [1, 3]
 
 @ %def parameters
 @
 <<nlo data: public>>=
   public :: fks_template_t
 <<nlo data: types>>=
   type :: fks_template_t
     logical :: subtraction_disabled = .false.
     integer :: mapping_type = FKS_DEFAULT
     logical :: count_kinematics = .false.
     real(default) :: fks_dij_exp1
     real(default) :: fks_dij_exp2
     real(default) :: xi_min
     real(default) :: y_max
     real(default) :: xi_cut, delta_o, delta_i
     type(string_t), dimension(:), allocatable :: excluded_resonances
     integer :: n_f
   contains
   <<nlo data: fks template: TBP>>
   end type fks_template_t
 
 @ %def fks_template_t
 @
 <<nlo data: fks template: TBP>>=
   procedure :: write => fks_template_write
 <<nlo data: procedures>>=
   subroutine fks_template_write (template, unit)
     class(fks_template_t), intent(in) :: template
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,'(1x,A)') 'FKS Template: '
     write (u,'(1x,A)', advance = 'no') 'Mapping Type: '
     select case (template%mapping_type)
     case (FKS_DEFAULT)
        write (u,'(A)') 'Default'
     case (FKS_RESONANCES)
        write (u,'(A)') 'Resonances'
     case default
        write (u,'(A)') 'Unkown'
     end select
     write (u,'(1x,A,ES4.3,ES4.3)') 'd_ij exponentials: ', &
        template%fks_dij_exp1, template%fks_dij_exp2
     write (u, '(1x,A,ES4.3,ES4.3)') 'xi_cut: ', &
        template%xi_cut
     write (u, '(1x,A,ES4.3,ES4.3)') 'delta_o: ', &
        template%delta_o
     write (u, '(1x,A,ES4.3,ES4.3)') 'delta_i: ', &
          template%delta_i
   end subroutine fks_template_write
 
 @ %def fks_template_write
 @ Set FKS parameters. $\xi_{\text{cut}}, \delta_o$ and $\delta_{\mathrm{I}}$ steer the ratio of the integrated and real subtraction.
 <<nlo data: fks template: TBP>>=
   procedure :: set_parameters => fks_template_set_parameters
 <<nlo data: procedures>>=
   subroutine fks_template_set_parameters (template, exp1, exp2, xi_min, &
     y_max, xi_cut, delta_o, delta_i)
     class(fks_template_t), intent(inout) :: template
     real(default), intent(in) :: exp1, exp2
     real(default), intent(in) :: xi_min, y_max, &
          xi_cut, delta_o, delta_i
     template%fks_dij_exp1 = exp1
     template%fks_dij_exp2 = exp2
     template%xi_min = xi_min
     template%y_max = y_max
     template%xi_cut = xi_cut
     template%delta_o = delta_o
     template%delta_i = delta_i
   end subroutine fks_template_set_parameters
 
 @ %def fks_template_set_parameters
 <<nlo data: fks template: TBP>>=
   procedure :: set_mapping_type => fks_template_set_mapping_type
 <<nlo data: procedures>>=
   subroutine fks_template_set_mapping_type (template, val)
     class(fks_template_t), intent(inout) :: template
     integer, intent(in) :: val
     template%mapping_type = val
   end subroutine fks_template_set_mapping_type
 
 @ %def fks_template_set_mapping_type
 @
 <<nlo data: fks template: TBP>>=
   procedure :: set_counter => fks_template_set_counter
 <<nlo data: procedures>>=
   subroutine fks_template_set_counter (template)
     class(fks_template_t), intent(inout) :: template
     template%count_kinematics = .true.
   end subroutine fks_template_set_counter
 
 @ %def fks_template_set_counter
 @
 <<nlo data: public>>=
   public :: real_scales_t
 <<nlo data: types>>=
   type :: real_scales_t
      real(default) :: scale
      real(default) :: ren_scale
      real(default) :: fac_scale
      real(default) :: scale_born
      real(default) :: fac_scale_born
      real(default) :: ren_scale_born
   end type real_scales_t
 
 @ %def real_scales_t
 @
 <<nlo data: public>>=
   public :: get_threshold_momenta
 <<nlo data: procedures>>=
   function get_threshold_momenta (p) result (p_thr)
     type(vector4_t), dimension(4) :: p_thr
     type(vector4_t), intent(in), dimension(:) :: p
     p_thr(1) = p(THR_POS_WP) + p(THR_POS_B)
     p_thr(2) = p(THR_POS_B)
     p_thr(3) = p(THR_POS_WM) + p(THR_POS_BBAR)
     p_thr(4) = p(THR_POS_BBAR)
   end function get_threshold_momenta
 
 @ %def get_threshold_momenta
 @
 \subsection{Putting it together}
 <<nlo data: public>>=
   public :: nlo_settings_t
 <<nlo data: types>>=
   type :: nlo_settings_t
      logical :: use_internal_color_correlations = .true.
      logical :: use_internal_spin_correlations = .false.
      logical :: use_resonance_mappings = .false.
      logical :: combined_integration = .false.
      logical :: fixed_order_nlo = .false.
      logical :: test_soft_limit = .false.
      logical :: test_coll_limit = .false.
      logical :: test_anti_coll_limit = .false.
      integer, dimension(:), allocatable :: selected_alr
      integer :: factorization_mode = NO_FACTORIZATION
      !!! Probably not the right place for this. Revisit after refactoring
      real(default) :: powheg_damping_scale = zero
      type(fks_template_t) :: fks_template
      type(string_t) :: virtual_selection
      logical :: virtual_resonance_aware_collinear = .true.
      logical :: use_born_scale = .false.
      logical :: cut_all_real_sqmes = .false.
      type(string_t) :: nlo_correction_type
+     logical :: reuse_amplitudes_fks = .false.
   contains
   <<nlo data: nlo settings: TBP>>
   end type nlo_settings_t
 
 @ %def nlo_settings_t
 @
 <<nlo data: nlo settings: TBP>>=
 procedure :: init => nlo_settings_init
 <<nlo data: procedures>>=
   subroutine nlo_settings_init (nlo_settings, var_list, fks_template)
     class(nlo_settings_t), intent(inout) :: nlo_settings
     type(var_list_t), intent(in) :: var_list
     type(fks_template_t), intent(in), optional :: fks_template
     type(string_t) :: color_method
     if (present (fks_template)) nlo_settings%fks_template = fks_template
     color_method = var_list%get_sval (var_str ('$correlation_me_method'))
     if (color_method == "")  color_method = var_list%get_sval (var_str ('$method'))
     nlo_settings%use_internal_color_correlations = color_method == 'omega' &
            .or. color_method == 'threshold'
     nlo_settings%combined_integration = var_list%get_lval &
            (var_str ("?combined_nlo_integration"))
     nlo_settings%fixed_order_nlo = var_list%get_lval &
            (var_str ("?fixed_order_nlo_events"))
     nlo_settings%test_soft_limit = var_list%get_lval (var_str ('?test_soft_limit'))
     nlo_settings%test_coll_limit = var_list%get_lval (var_str ('?test_coll_limit'))
     nlo_settings%test_anti_coll_limit = var_list%get_lval (var_str ('?test_anti_coll_limit'))
     call setup_alr_selection ()
     nlo_settings%virtual_selection = var_list%get_sval (var_str ('$virtual_selection'))
     nlo_settings%virtual_resonance_aware_collinear = &
          var_list%get_lval (var_str ('?virtual_collinear_resonance_aware'))
     nlo_settings%powheg_damping_scale = &
          var_list%get_rval (var_str ('powheg_damping_scale'))
     nlo_settings%use_born_scale = &
          var_list%get_lval (var_str ("?nlo_use_born_scale"))
     nlo_settings%cut_all_real_sqmes = &
          var_list%get_lval (var_str ("?nlo_cut_all_real_sqmes"))
     nlo_settings%nlo_correction_type = var_list%get_sval (var_str ('$nlo_correction_type'))
+    nlo_settings%reuse_amplitudes_fks = var_list%get_lval (var_str ('?nlo_reuse_amplitudes_fks'))
   contains
     subroutine setup_alr_selection ()
       type(string_t) :: alr_selection
       type(string_t), dimension(:), allocatable :: alr_split
       integer :: i, i1, i2
       alr_selection = var_list%get_sval (var_str ('$select_alpha_regions'))
       if (string_contains_word (alr_selection, var_str (","))) then
          call split_string (alr_selection, var_str (","), alr_split)
          allocate (nlo_settings%selected_alr (size (alr_split)))
          do i = 1, size (alr_split)
             nlo_settings%selected_alr(i) = read_ival(alr_split(i))
          end do
       else if (string_contains_word (alr_selection, var_str (":"))) then
          call split_string (alr_selection, var_str (":"), alr_split)
          if (size (alr_split) == 2) then
             i1 = read_ival (alr_split(1))
             i2 = read_ival (alr_split(2))
             allocate (nlo_settings%selected_alr (i2 - i1 + 1))
             do i = 1, i2 - i1 + 1
                nlo_settings%selected_alr(i) = read_ival (alr_split(i))
             end do
          else
             call msg_fatal ("select_alpha_regions: ':' specifies a range!")
          end if
       else if (len(alr_selection) == 1) then
          allocate (nlo_settings%selected_alr (1))
          nlo_settings%selected_alr(1) = read_ival (alr_selection)
       end if
       if (allocated (alr_split)) deallocate (alr_split)
     end subroutine setup_alr_selection
   end subroutine nlo_settings_init
 
 @ %def nlo_settings_init
 @
 <<nlo data: nlo settings: TBP>>=
   procedure :: write => nlo_settings_write
 <<nlo data: procedures>>=
   subroutine nlo_settings_write (nlo_settings, unit)
     class(nlo_settings_t), intent(in) :: nlo_settings
     integer, intent(in), optional :: unit
     integer :: i, u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, '(A)') 'nlo_settings:'
     write (u, '(3X,A,L1)') 'internal_color_correlations = ', &
          nlo_settings%use_internal_color_correlations
     write (u, '(3X,A,L1)') 'internal_spin_correlations = ', &
          nlo_settings%use_internal_spin_correlations
     write (u, '(3X,A,L1)') 'use_resonance_mappings = ', &
          nlo_settings%use_resonance_mappings
     write (u, '(3X,A,L1)') 'combined_integration = ', &
          nlo_settings%combined_integration
     write (u, '(3X,A,L1)') 'test_soft_limit = ', &
          nlo_settings%test_soft_limit
     write (u, '(3X,A,L1)') 'test_coll_limit = ', &
          nlo_settings%test_coll_limit
     write (u, '(3X,A,L1)') 'test_anti_coll_limit = ', &
          nlo_settings%test_anti_coll_limit
     if (allocated (nlo_settings%selected_alr)) then
        write (u, '(3x,A)', advance = "no") 'selected alpha regions = ['
        do i = 1, size (nlo_settings%selected_alr)
           write (u, '(A,I0)', advance = "no") ",", nlo_settings%selected_alr(i)
        end do
        write (u, '(A)') "]"
     end if
     write (u, '(3X,A,' // FMT_15 // ')') 'powheg_damping_scale = ', &
          nlo_settings%powheg_damping_scale
     write (u, '(3X,A,A)') 'virtual_selection = ', &
          char (nlo_settings%virtual_selection)
     write (u, '(3X,A,A)') 'Real factorization mode = ', &
          char (factorization_mode (nlo_settings%factorization_mode))
   contains
     function factorization_mode (fm)
       type(string_t) :: factorization_mode
       integer, intent(in) :: fm
       select case (fm)
       case (NO_FACTORIZATION)
          factorization_mode = var_str ("None")
       case (FACTORIZATION_THRESHOLD)
          factorization_mode = var_str ("Threshold")
       case default
          factorization_mode = var_str ("Undefined!")
       end select
     end function factorization_mode
   end subroutine nlo_settings_write
 
 @ %def nlo_settings_write
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Contribution of divergencies due to PDF Evolution}
 
 References:
 \begin{itemize}
 \item arXiv:hep-ph/9512328, (2.1)-(2.5), (4.29)-(4.53)
 \item arXiv:0709.2092, (2.102)-(2.106)
 \end{itemize}
 
 The parton distrubition densities have to be evaluated at NLO, too.
 The NLO PDF evolution is given by
 \begin{equation}
   \label{eqn:pdf_nlo}
   f (\bar{x}) = \int_0^1 \int_0^1 dx dz f(x) \Gamma(z) \delta (\bar{x} - x z),
 \end{equation}
 where $\Gamma$ are the DGLAP evolution kernels for an $a \to d$ splitting,
 \begin{equation}
   \label{eqn:dglap}
   \Gamma_a^{(d)} = \delta_{ad}\delta(1-x) - \frac{\alpha_s}{2\pi} \left(\frac{1}{\epsilon} P_{ad}(x,0) - K_{ad}(x)\right) + \mathcal{O}(\alpha_s^2).
 \end{equation}
 $K_{ad}$ is a renormalization scheme matching factor, which is exactly zero in $\overline{\text{MS}}$.
 Let the leading-order hadronic cross section be given by
 \begin{equation}
   \label{eqn:xsec_hadro_lo}
   d\sigma^{(0)}(s) = \int dx_\oplus dx_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus) d\tilde{\sigma}^{(0)} (x_\oplus x_\ominus s),
 \end{equation}
 then the NLO hadronic cross section is
 \begin{equation}
   \label{eqn:xsec_hadro_nlo}
   d\sigma^{(1)}(s) = \int dx_\oplus dx_\ominus dz_\oplus dz_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus)
                      \underbrace{\Gamma_\oplus (z_\oplus) \Gamma_\ominus (z_\ominus) d\tilde{\sigma}^{(1)} (z_\oplus z_\ominus s)}_{d\hat{\sigma}^{(1)}}.
 \end{equation}
 $d\hat{\sigma}$ is called the subtracted partonic cross section. Expanding in $\alpha_s$ we find
 \begin{align}
   d\hat{\sigma}^{(0)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(0)} (k_1, k_2), \\
   d\hat{\sigma}^{(1)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(1)} (k_1, k_2) \\
                                      &+ \frac{\alpha_s}{2\pi} \sum_d \int dx \left (\frac{1}{\epsilon} P_{da}(x,0) - K_{da}(x)\right) d\tilde{\sigma}_{db}^{(0)}(xk_1, k_2)\\
                                      &+ \frac{\alpha_s}{2\pi} \sum_d \int \left (\frac{1}{\epsilon} P_{db} (x, 0) - K_{db}(x)\right) d\tilde{\sigma}_{ad}^{(0)}(k_1, xk_2).\\
                                      &= d\tilde{\sigma}_{ab}^{(1)} + d\tilde{\sigma}_{ab}^{(cnt,+)} + d\tilde{\sigma}_{ab}^{(cnt,-)}
 \end{align}
 
 Let us now turn to the soft-subtracted real part of the cross section. For ease of notation, it is constrained to one singular region,
 \begin{align*}
   \label{eqn:R-in}
   d\sigma^{(in)}_\alpha &= \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon\left(\frac{\log \xi}{\xi}\right)_{c}\right] (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha \\
                  &\times  \frac{1}{2(2\pi)^{3-2\epsilon}} \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \left( 1 - y^2\right)^{-1-\epsilon} d\phi d\xi dy d\Omega^{2-2\epsilon},
 \end{align*}
 where we regularize collinear divergencies using the identity
 \begin{equation*}
   \left (1 - y^2 \right)^{-1-\epsilon} = -\frac{2^{-\epsilon}}{2\epsilon} \left (\delta(1-y) + \delta(1+y)\right)
      + \underbrace{\frac{1}{2} \left[ \left (\frac {1}{1-y}\right)_{c} + \left (\frac{1}{1+y}\right)_{c} \right]}_{\mathcal{P}(y)}.
 \end{equation*}
 This enables us to split the cross section into a finite and a singular part. The latter can further be separated into a contribution of the incoming and of the outgoing particles,
 \begin{equation*}
   d\sigma^{(in)}_\alpha = d\sigma^{(in,+)}_\alpha + d\sigma^{(in,-)}_\alpha + d\sigma^{(in,f)}_\alpha.
 \end{equation*}
 They are given by
 \begin{align}
   d\sigma^{(in,f)}_\alpha = & \mathcal{P}(y) \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \frac{1}{2(2\pi)^{3-2\epsilon}}
      \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \nonumber\\
      & \times (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon}
   \label{eqn:sigma-f}
 \end{align}
 and
 \begin{align}
   d\sigma^{(in,\pm)}_\alpha &= -\frac{2^{-\epsilon}}{2\epsilon} \delta (1 \mp y) \left[ \left( \frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \nonumber\\
                     & \times \frac{1}{2(2\pi)^{3-2\epsilon}} \left( \frac{\sqrt{s}}{2}\right)^{2-2\epsilon} (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon}.
   \label{eqn:sigma-pm}
 \end{align}
 Equation \ref{eqn:sigma-f} is the contribution to the real cross section which is computed in [[evaluate_region_isr]]. It is regularized both in the soft and collinear limit via the plus distributions.
 Equation \ref{eqn:sigma-pm} is a different contribution. It is only present exactly in the collinear limit, due to the delta function. The divergences present in this term do not completely cancel out
 divergences in the virtual matrix element, because the beam axis is distinguished. Thus, the conditions in which the KLN theorem applies are not met. To see this, we carry out the collinear limit, obtaining
 \begin{equation*}
   \lim_{y \to 1} (1-y^2)\xi^2\mathcal{R}_\alpha = 8\pi\alpha_s \mu^{2\epsilon} \left(\frac{2}{\sqrt{s}}\right)^2 \xi P^<(1-\xi, \epsilon) \mathcal{R}_\alpha,
 \end{equation*}
 with the Altarelli-Parisi splitting kernel for $z < 1$, $P^<(z,\epsilon)$. Moreover, $\lim_{\vec{k} \parallel \vec{k}_1} d\phi = d\phi_3$ violates spatial averaging. The integration over the spherical angle $d\Omega$ can be carried out easily, yielding a factor of $2\pi^{1-\epsilon} / \Gamma(1-\epsilon)$.
 This allows us to redefine $\epsilon$,
 \begin{equation}
   \frac{1}{\epsilon} - \gamma_E + \log(4\pi) \to \frac{1}{\epsilon}.
 \end{equation}
 Coming back to $d\tilde{\sigma}_{ab}^{(cnt,+)}$ in order to make a connection to $d{\sigma}^{(in,+)}_\alpha$, we relate $P_{ab}(z,0)$ to $P^<_{ab}(z,0)$ via the equation
 \begin{equation*}
   P_{ab}(z,0) = (1-z)P_{ab}^<(z,0)\left(\frac{1}{1-z}\right)_+ + \gamma(a)\delta_{ab}\delta(1-z),
 \end{equation*}
 which yields
 \begin{equation} \label{eqn:sigma-cnt}
   d\tilde{\sigma}^{(cnt,+)}_{\alpha} = \frac{\alpha_s}{2\pi} \sum_d \left\lbrace -K_{da}(1-\xi) + \frac{1}{\epsilon} \left[\left(\frac{1}{\xi}\right)_+ \xi P_{da}^<(1-\xi,0)
                            + \delta_{da}\delta(\xi)\gamma(d)\right]\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy.
 \end{equation}
 This term has the same pole structure as eqn. \ref{eqn:sigma-pm}. This makes clear that the quantity
 \begin{equation}
   d\hat{\sigma}^{(in,+)} = d\tilde{\sigma}^{(in,+)} + d\tilde{\sigma}^{(cnt,+)}
 \end{equation}
 has no collinear poles. Therefore, our task is to add up eqns. \ref{eqn:sigma-pm} and \ref{eqn:sigma-cnt} in order to compute the finite remainder. This is the integrand which is evaluated in the [[dglap_remnant]] component.\\
 So, we have to perform an expansion of $d\hat{\sigma}^{(in,+)}$ in $\epsilon$. Hereby, we must not neglect the implicit $\epsilon$-dependence of $P^<$, which leads to additional terms involving the
 first derivative,
 \begin{equation*}
   P_{ab}^<(z,\epsilon) = P_{ab}^<(z,0) + \epsilon \frac{\partial P_{ab}^<(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} + \mathcal{O}(\alpha_s^2).
 \end{equation*}
 This finally gives us the equation for the collinear remnant. Note that there is still one soft $1/\epsilon$-pole, which cancels out with the corresponding expression in the soft-virtual terms.
 \begin{align} \label{eqn:sigma-in-p-final}
   d\hat{\sigma}^{(in,+)} &= \frac{\alpha_s}{2\pi} \frac{1}{\epsilon} \gamma(a) \mathcal{R}_\alpha \mathcal{S}_\alpha \nonumber\\
                          &+ \frac{\alpha_s}{2\pi} \sum_d \left\lbrace (1-z) P_{da}^<(z,0)\left[\left(\frac{1}{1-z}\right)_{c} \log\frac{s\delta_{\mathrm{I}}}{2\mu^2} + 2 \left(\frac{\log(1-z)}{1-z}\right)_{c}\right] \right. \nonumber\\
                          &\left . -(1-z)\frac{\partial P_{da}^<(z,\epsilon)}{\partial \epsilon} \left(\frac{1}{1-z}\right)_{c} - K_{da}(z)\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy
 \end{align}
 
 
 <<[[dglap_remnant.f90]]>>=
 <<File header>>
 
 module dglap_remnant
 
 <<Use kinds with double>>
 <<Use strings>>
   use numeric_utils
   use diagnostics
   use constants
   use physics_defs
   use pdg_arrays
   use phs_fks, only: isr_kinematics_t
   use fks_regions, only: region_data_t
 
   use nlo_data
 
 <<Standard module head>>
 
 <<dglap remnant: public>>
 
 <<dglap remnant: types>>
 
 contains
 
 <<dglap remnant: procedures>>
 
 end module dglap_remnant
 
 @ %def module dglap_remnant
 @
 <<dglap remnant: public>>=
   public :: dglap_remnant_t
 <<dglap remnant: types>>=
   type :: dglap_remnant_t
      type(nlo_settings_t), pointer :: settings => null ()
      type(region_data_t), pointer :: reg_data => null ()
      type(isr_kinematics_t), pointer :: isr_kinematics => null ()
      real(default), dimension(:), allocatable :: sqme_born
      real(default), dimension(:,:), allocatable :: sf_factors
    contains
    <<dglap remnant: dglap remnant: TBP>>
   end type dglap_remnant_t
 
 @ %def dglap_remnant_t
 @
 <<dglap remnant: dglap remnant: TBP>>=
   procedure :: init => dglap_remnant_init
 <<dglap remnant: procedures>>=
   subroutine dglap_remnant_init (dglap, settings, reg_data, isr_kinematics)
     class(dglap_remnant_t), intent(inout) :: dglap
     type(nlo_settings_t), intent(in), target :: settings
     type(region_data_t), intent(in), target :: reg_data
     integer :: n_flv_born
     type(isr_kinematics_t), intent(in), target :: isr_kinematics
     dglap%reg_data => reg_data
     n_flv_born = reg_data%get_n_flv_born ()
     allocate (dglap%sf_factors (reg_data%n_regions, 0:reg_data%n_in))
     dglap%sf_factors = zero
     dglap%settings => settings
     allocate (dglap%sqme_born(n_flv_born))
     dglap%sqme_born = zero
     dglap%isr_kinematics => isr_kinematics
   end subroutine dglap_remnant_init
 
 @ %def dglap_remnant_init
 @ Evaluates formula \ref{eqn:sigma-in-p-final}. Note that, as also in the case for the
 real subtraction, we have to take into account an additional term, occuring because the
 integral the plus distribution is evaluated over is not constrained on the interval $[0,1]$.
 Explicitly, this means (see JHEP 06(2010)043, (4.11)-(4.12))
 \begin{align}
   \int_{\bar{x}_\oplus}^1 dz \left( \frac{1}{1-z} \right)_{\xi_{\text{cut}}} & = \log \frac{1-\bar{x}_\oplus}{\xi_{\text{cut}}} f(1) + \int_{\bar{x}_\oplus}^1 \frac{f(z) - f(1)}{1-z}, \\
   \int_{\bar{x}_\oplus}^1 dz \left(\frac{\log(1-z)}{1-z}\right)_{\xi_{\text{cut}}} f(z) & = \frac{1}{2}\left( \log^2(1-\bar{x}_\oplus) - \log^2 (\xi_{\text{cut}}) \right)f(1) + \int_{\bar{x}_\oplus}^1 \frac{\log(1-z)[f(z) - f(1)]}{1-z},
 \end{align}
 and the same of course for $\bar{x}_\ominus$. These two terms are stored in the [[plus_dist_remnant]] variable below.
 
 The option [[separate_uborns]] allows to compute the contribution of the DGLAP remnant
 separately for each underlying Born flavor structure. We need this option during
 event generation to generate counter events with a specific Born flavor structure.
 <<dglap remnant: dglap remnant: TBP>>=
   procedure :: evaluate => dglap_remnant_evaluate
 <<dglap remnant: procedures>>=
   subroutine dglap_remnant_evaluate (dglap, alpha_s, separate_uborns, sqme_dglap)
     class(dglap_remnant_t), intent(inout) :: dglap
     real(default), intent(in) :: alpha_s
     logical, intent(in) :: separate_uborns
     real(default), intent(inout), dimension(:) :: sqme_dglap
     integer :: alr, emitter
     real(default) :: sqme_alr
     logical, dimension(:,:,:), allocatable :: evaluated
     real(default) :: sb, fac_scale2
     sb = dglap%isr_kinematics%sqrts_born**2
     fac_scale2 = dglap%isr_kinematics%fac_scale**2
     allocate (evaluated(dglap%reg_data%get_n_flv_born (), dglap%reg_data%get_n_flv_real (), &
          dglap%reg_data%n_in))
     evaluated = .false.
     do alr = 1, dglap%reg_data%n_regions
        sqme_alr = zero
        emitter = dglap%reg_data%regions(alr)%emitter
        if (emitter > dglap%reg_data%n_in) cycle
        associate (i_flv_born => dglap%reg_data%regions(alr)%uborn_index, &
                i_flv_real => dglap%reg_data%regions(alr)%real_index)
           if (emitter == 0) then
              do emitter = 1, 2
                 if (evaluated(i_flv_born, i_flv_real, emitter)) cycle
                 call evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated)
              end do
           else if (emitter > 0) then
              if (evaluated(i_flv_born, i_flv_real, emitter)) cycle
              call evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated)
           end if
           if (separate_uborns) then
              sqme_dglap(i_flv_born) = sqme_dglap(i_flv_born) + alpha_s / twopi * sqme_alr
           else
              sqme_dglap(1) = sqme_dglap(1) + alpha_s / twopi * sqme_alr
           end if
        end associate
     end do
 
   contains
   <<dglap remnant: dglap remnant evaluate: procedures>>
   end subroutine dglap_remnant_evaluate
 
 @ %def dglap_remnant_evaluate
 @ We introduce $\hat{P}(z, \epsilon) = (1 - z) P(z, \epsilon)$ and have
 \begin{align}
   \hat{P}_{g\to gg}(z) & = 2C_A \left[z + \frac{(1-z)^2}{z} + z(1-z)^2\right], \\
   \hat{P}_{g\to qq}(z) & = C_F (1-z) \frac{1 + (1-z)^2}{z}, \\
   \hat{P}_{q\to gq}(z) & = T_F (1 - z - 2z(1-z)^2), \\
   \hat{P}_{q\to qg}(z) & = C_F (1 + z^2).
 \end{align}
 <<dglap remnant: dglap remnant evaluate: procedures>>=
   function p_hat_gtogg (z)
     real(default) :: p_hat_gtogg
   <<p variables>>
     p_hat_gtogg = two * CA * (z + onemz**2 / z + z * onemz**2)
   end function p_hat_gtogg
 
   function p_hat_gtoqq (z)
     real(default) :: p_hat_gtoqq
   <<p variables>>
     p_hat_gtoqq = CF * onemz / z * (one + onemz**2)
   end function p_hat_gtoqq
 
   function p_hat_qtogq (z)
     real(default) :: p_hat_qtogq
   <<p variables>>
     p_hat_qtogq = TR * (onemz - two * z * onemz**2)
   end function p_hat_qtogq
 
   function p_hat_qtoqg (z)
     real(default) :: p_hat_qtoqg
     real(default), intent(in) :: z
     p_hat_qtoqg = CF * (one + z**2)
   end function p_hat_qtoqg
 
 @ %def p_hat_qtoqg, p_hat_qtogq, p_hat_gtoqq, p_hat_gtogg
 @
 \begin{align}
   \frac{\partial P_{g\to gg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = 0, \\
   \frac{\partial P_{g\to qq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F z, \\
   \frac{\partial P_{q\to gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -
 2 T_F z (1-z), \\
   \frac{\partial P_{q\to qg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F (1-z).\\
 \end{align}
 <<dglap remnant: dglap remnant evaluate: procedures>>=
   function p_derived_gtogg (z)
     real(default) :: p_derived_gtogg
     real(default), intent(in) :: z
     p_derived_gtogg = zero
   end function p_derived_gtogg
 
   function p_derived_gtoqq (z)
     real(default) :: p_derived_gtoqq
     real(default), intent(in) :: z
     p_derived_gtoqq = -CF * z
   end function p_derived_gtoqq
 
   function p_derived_qtogq (z)
     real(default) :: p_derived_qtogq
   <<p variables>>
     p_derived_qtogq = -two * TR * z * onemz
   end function p_derived_qtogq
 
   function p_derived_qtoqg (z)
     real(default) :: p_derived_qtoqg
   <<p variables>>
     p_derived_qtoqg = -CF * onemz
   end function p_derived_qtoqg
 
 @ %def p_derived_gtogg, p_derived_gtoqq, p_derived_qtogq, p_derived_qtoqg
 @
 <<dglap remnant: dglap remnant evaluate: procedures>>=
 subroutine evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated)
   integer, intent(in) :: alr, emitter, i_flv_born, i_flv_real
   real(default), intent(inout) :: sqme_alr
   logical, intent(inout), dimension(:,:,:) :: evaluated
   real(default) :: z, jac
   real(default) :: factor, factor_soft, plus_dist_remnant
   real(default) :: xb, onemz
   real(default) :: sqme_scaled
   integer :: flv_em, flv_rad
   associate (template => dglap%settings%fks_template)
      z = dglap%isr_kinematics%z(emitter)
      flv_rad = dglap%reg_data%regions(alr)%flst_real%flst(dglap%reg_data%n_legs_real)
      flv_em = dglap%reg_data%regions(alr)%flst_real%flst(emitter)
      jac = dglap%isr_kinematics%jacobian(emitter)
      onemz = one - z
      factor = log (sb * template%delta_i / two / z / fac_scale2) / &
           onemz + two * log (onemz) / onemz
      factor_soft = log (sb * template%delta_i / two / fac_scale2) / &
           onemz + two * log (onemz) / onemz
      xb = dglap%isr_kinematics%x(emitter)
      plus_dist_remnant = log ((one - xb) / template%xi_cut) * log (sb * template%delta_i / &
           two / fac_scale2) + (log (one - xb)**2 - log (template%xi_cut)**2)
   end associate
   sqme_scaled = dglap%sqme_born(i_flv_born) * dglap%sf_factors(alr, emitter)
   if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then
      sqme_alr = sqme_alr + p_hat_gtogg(z) * factor / z * sqme_scaled * jac &
           - p_hat_gtogg(one) * factor_soft * dglap%sqme_born(i_flv_born) * jac &
           + p_hat_gtogg(one) * plus_dist_remnant * dglap%sqme_born(i_flv_born)
   else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
      sqme_alr = sqme_alr + p_hat_qtoqg(z) * factor / z * sqme_scaled * jac &
           - p_derived_qtoqg(z) / z * sqme_scaled * jac &
           - p_hat_qtoqg(one) * factor_soft * dglap%sqme_born(i_flv_born) * jac &
           + p_hat_qtoqg(one) * plus_dist_remnant * dglap%sqme_born(i_flv_born)
   else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then
      sqme_alr = sqme_alr + (p_hat_gtoqq(z) * factor - p_derived_gtoqq(z)) / z * jac * &
           sqme_scaled
   else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then
      sqme_alr = sqme_alr + (p_hat_qtogq(z) * factor - p_derived_qtogq(z)) / z * sqme_scaled * jac
   else
      sqme_alr = sqme_alr + zero
   end if
   evaluated(i_flv_born, i_flv_real, emitter) = .true.
 end subroutine evaluate_alr
 @ %dglap_remnant_evaluate_alr
 @
 <<p variables>>=
   real(default), intent(in) :: z
   real(default) :: onemz
   onemz = one - z
 
 @ %def variables
 @
 <<dglap remnant: dglap remnant: TBP>>=
   procedure :: final => dglap_remnant_final
 <<dglap remnant: procedures>>=
   subroutine dglap_remnant_final (dglap)
     class(dglap_remnant_t), intent(inout) :: dglap
     if (associated (dglap%isr_kinematics)) nullify (dglap%isr_kinematics)
     if (associated (dglap%reg_data)) nullify (dglap%reg_data)
     if (associated (dglap%settings)) nullify (dglap%settings)
     if (allocated (dglap%sqme_born)) deallocate (dglap%sqme_born)
     if (allocated (dglap%sf_factors)) deallocate (dglap%sf_factors)
   end subroutine dglap_remnant_final
 
 @ %def dglap_remnant_final
 @
 \section{Dispatch}
 @
 <<[[dispatch_fks.f90]]>>=
 <<File header>>
 
 module dispatch_fks
 
 <<Use kinds>>
 <<Use strings>>
   use string_utils, only: split_string
   use variables, only: var_list_t
   use nlo_data, only: fks_template_t, FKS_DEFAULT, FKS_RESONANCES
 
 <<Standard module head>>
 
 <<Dispatch fks: public>>
 
 contains
 
 <<Dispatch fks: procedures>>
 
 end module dispatch_fks
 @ %def dispatch_fks
 @ Initialize parameters used to optimize FKS calculations.
 <<Dispatch fks: public>>=
   public :: dispatch_fks_s
 <<Dispatch fks: procedures>>=
   subroutine dispatch_fks_s (fks_template, var_list)
     type(fks_template_t), intent(inout) :: fks_template
     type(var_list_t), intent(in) :: var_list
     real(default) :: fks_dij_exp1, fks_dij_exp2
     type(string_t) :: fks_mapping_type
     logical :: subtraction_disabled
     type(string_t) :: exclude_from_resonance
     fks_dij_exp1 = &
          var_list%get_rval (var_str ("fks_dij_exp1"))
     fks_dij_exp2 = &
          var_list%get_rval (var_str ("fks_dij_exp2"))
     fks_mapping_type = &
          var_list%get_sval (var_str ("$fks_mapping_type"))
     subtraction_disabled = &
          var_list%get_lval (var_str ("?disable_subtraction"))
     exclude_from_resonance = &
          var_list%get_sval (var_str ("$resonances_exclude_particles"))
     if (exclude_from_resonance /= var_str ("default")) &
        call split_string (exclude_from_resonance, var_str (":"), &
        fks_template%excluded_resonances)
     call fks_template%set_parameters ( &
          exp1 = fks_dij_exp1, exp2 = fks_dij_exp2, &
          xi_min = var_list%get_rval (var_str ("fks_xi_min")), &
          y_max = var_list%get_rval (var_str ("fks_y_max")), &
          xi_cut = var_list%get_rval (var_str ("fks_xi_cut")), &
          delta_o = var_list%get_rval (var_str ("fks_delta_o")), &
          delta_i = var_list%get_rval (var_str ("fks_delta_i")))
     select case (char (fks_mapping_type))
     case ("default")
        call fks_template%set_mapping_type (FKS_DEFAULT)
     case ("resonances")
        call fks_template%set_mapping_type (FKS_RESONANCES)
     end select
     fks_template%subtraction_disabled = subtraction_disabled
     fks_template%n_f = var_list%get_ival (var_str ("alphas_nf"))
   end subroutine dispatch_fks_s
 
 @ %def dispatch_fks_s
 @