Index: trunk/src/qft/qft.nw =================================================================== --- trunk/src/qft/qft.nw (revision 8221) +++ trunk/src/qft/qft.nw (revision 8222) @@ -1,15430 +1,15427 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: Quantum Field Theory concepts %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Quantum Field Theory Concepts} \includemodulegraph{qft} The objects and methods defined here implement concepts and data for the underlying quantum field theory that we use for computing matrix elements and processes. \begin{description} \item[model\_data] Fields and coupling parameters, operators as vertex structures, for a specific model. \item[model\_testbed] Provide hooks to deal with a [[model_data]] extension without referencing it explicitly. \item[helicities] Types and methods for spin density matrices. \item[colors] Dealing with colored particles, using the color-flow representation. \item[flavors] PDG codes and particle properties, depends on the model. \item[quantum\_numbers] Quantum numbers and density matrices for entangled particle systems. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Model Data} These data represent a specific Lagrangian in numeric terms. That is, we have the fields with their quantum numbers, the masses, widths and couplings as numerical values, and the vertices as arrays of fields. We do not store the relations between coupling parameters. They should be represented by expressions for evaluation, implemented as Sindarin objects in a distinct data structure. Neither do we need the algebraic structure of vertices. The field content of vertices is required for the sole purpose of setting up phase space. <<[[model_data.f90]]>>= <> module model_data use, intrinsic :: iso_c_binding !NODEP! <> use kinds, only: i8, i32 use kinds, only: c_default_float <> use format_defs, only: FMT_19 use io_units use diagnostics use md5 use hashes, only: hash use physics_defs, only: UNDEFINED, SCALAR <> <> <> <> contains <> end module model_data @ %def model_data @ \subsection{Physics Parameters} Couplings, masses, and widths are physics parameters. Each parameter has a unique name (used, essentially, for diagnostics output and debugging) and a value. The value may be a real or a complex number, so we provide to implementations of an abstract type. <>= public :: modelpar_data_t <>= type, abstract :: modelpar_data_t private type(string_t) :: name contains <> end type modelpar_data_t type, extends (modelpar_data_t) :: modelpar_real_t private real(default) :: value end type modelpar_real_t type, extends (modelpar_data_t) :: modelpar_complex_t private complex(default) :: value end type modelpar_complex_t @ %def modelpar_data_t modelpar_real_t modelpar_complex_t @ Output for diagnostics. Non-advancing. <>= procedure :: write => par_write <>= subroutine par_write (par, unit) class(modelpar_data_t), intent(in) :: par integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,1x,A)", advance="no") char (par%name), "= " select type (par) type is (modelpar_real_t) write (u, "(" // FMT_19 // ")", advance="no") par%value type is (modelpar_complex_t) write (u, "(" // FMT_19 // ",1x,'+',1x," // FMT_19 // ",1x,'I')", & advance="no") par%value end select end subroutine par_write @ %def par_write @ Pretty-printed on separate line, with fixed line length <>= procedure :: show => par_show <>= subroutine par_show (par, l, u) class(modelpar_data_t), intent(in) :: par integer, intent(in) :: l, u character(len=l) :: buffer buffer = par%name select type (par) type is (modelpar_real_t) write (u, "(4x,A,1x,'=',1x," // FMT_19 // ")") buffer, par%value type is (modelpar_complex_t) write (u, "(4x,A,1x,'=',1x," // FMT_19 // ",1x,'+',1x," & // FMT_19 // ",1x,'I')") buffer, par%value end select end subroutine par_show @ %def par_show @ Initialize with name and value. The type depends on the argument type. If the type does not match, the value is converted following Fortran rules. <>= generic :: init => modelpar_data_init_real, modelpar_data_init_complex procedure, private :: modelpar_data_init_real procedure, private :: modelpar_data_init_complex <>= subroutine modelpar_data_init_real (par, name, value) class(modelpar_data_t), intent(out) :: par type(string_t), intent(in) :: name real(default), intent(in) :: value par%name = name par = value end subroutine modelpar_data_init_real subroutine modelpar_data_init_complex (par, name, value) class(modelpar_data_t), intent(out) :: par type(string_t), intent(in) :: name complex(default), intent(in) :: value par%name = name par = value end subroutine modelpar_data_init_complex @ %def modelpar_data_init_real modelpar_data_init_complex @ Modify the value. We assume that the parameter has been initialized. The type (real or complex) must not be changed, and the name is also fixed. <>= generic :: assignment(=) => modelpar_data_set_real, modelpar_data_set_complex procedure, private :: modelpar_data_set_real procedure, private :: modelpar_data_set_complex <>= elemental subroutine modelpar_data_set_real (par, value) class(modelpar_data_t), intent(inout) :: par real(default), intent(in) :: value select type (par) type is (modelpar_real_t) par%value = value type is (modelpar_complex_t) par%value = value end select end subroutine modelpar_data_set_real elemental subroutine modelpar_data_set_complex (par, value) class(modelpar_data_t), intent(inout) :: par complex(default), intent(in) :: value select type (par) type is (modelpar_real_t) par%value = value type is (modelpar_complex_t) par%value = value end select end subroutine modelpar_data_set_complex @ %def modelpar_data_set_real modelpar_data_set_complex @ Return the parameter name. <>= procedure :: get_name => modelpar_data_get_name <>= function modelpar_data_get_name (par) result (name) class(modelpar_data_t), intent(in) :: par type(string_t) :: name name = par%name end function modelpar_data_get_name @ %def modelpar_data_get_name @ Return the value. In case of a type mismatch, follow Fortran conventions. <>= procedure, pass :: get_real => modelpar_data_get_real procedure, pass :: get_complex => modelpar_data_get_complex <>= elemental function modelpar_data_get_real (par) result (value) class(modelpar_data_t), intent(in), target :: par real(default) :: value select type (par) type is (modelpar_real_t) value = par%value type is (modelpar_complex_t) value = par%value end select end function modelpar_data_get_real elemental function modelpar_data_get_complex (par) result (value) class(modelpar_data_t), intent(in), target :: par complex(default) :: value select type (par) type is (modelpar_real_t) value = par%value type is (modelpar_complex_t) value = par%value end select end function modelpar_data_get_complex @ %def modelpar_data_get_real @ %def modelpar_data_get_complex @ Return a pointer to the value. This makes sense only for matching types. <>= procedure :: get_real_ptr => modelpar_data_get_real_ptr procedure :: get_complex_ptr => modelpar_data_get_complex_ptr <>= function modelpar_data_get_real_ptr (par) result (ptr) class(modelpar_data_t), intent(in), target :: par real(default), pointer :: ptr select type (par) type is (modelpar_real_t) ptr => par%value class default ptr => null () end select end function modelpar_data_get_real_ptr function modelpar_data_get_complex_ptr (par) result (ptr) class(modelpar_data_t), intent(in), target :: par complex(default), pointer :: ptr select type (par) type is (modelpar_complex_t) ptr => par%value class default ptr => null () end select end function modelpar_data_get_complex_ptr @ %def modelpar_data_get_real_ptr @ %def modelpar_data_get_complex_ptr @ \subsection{Field Data} The field-data type holds all information that pertains to a particular field (or particle) within a particular model. Information such as spin type, particle code etc.\ is stored within the object itself, while mass and width are associated to parameters, otherwise assumed zero. <>= public :: field_data_t <>= type :: field_data_t private type(string_t) :: longname integer :: pdg = UNDEFINED logical :: visible = .true. logical :: parton = .false. logical :: gauge = .false. logical :: left_handed = .false. logical :: right_handed = .false. logical :: has_anti = .false. logical :: p_is_stable = .true. logical :: p_decays_isotropically = .false. logical :: p_decays_diagonal = .false. logical :: p_has_decay_helicity = .false. integer :: p_decay_helicity = 0 logical :: a_is_stable = .true. logical :: a_decays_isotropically = .false. logical :: a_decays_diagonal = .false. logical :: a_has_decay_helicity = .false. integer :: a_decay_helicity = 0 logical :: p_polarized = .false. logical :: a_polarized = .false. type(string_t), dimension(:), allocatable :: name, anti type(string_t) :: tex_name, tex_anti integer :: spin_type = UNDEFINED integer :: isospin_type = 1 integer :: charge_type = 1 integer :: color_type = 1 real(default), pointer :: mass_val => null () class(modelpar_data_t), pointer :: mass_data => null () real(default), pointer :: width_val => null () class(modelpar_data_t), pointer :: width_data => null () integer :: multiplicity = 1 type(string_t), dimension(:), allocatable :: p_decay type(string_t), dimension(:), allocatable :: a_decay contains <> end type field_data_t @ %def field_data_t @ Initialize field data with PDG long name and PDG code. \TeX\ names should be initialized to avoid issues with accessing unallocated string contents. <>= procedure :: init => field_data_init <>= subroutine field_data_init (prt, longname, pdg) class(field_data_t), intent(out) :: prt type(string_t), intent(in) :: longname integer, intent(in) :: pdg prt%longname = longname prt%pdg = pdg prt%tex_name = "" prt%tex_anti = "" end subroutine field_data_init @ %def field_data_init @ Copy quantum numbers from another particle. Do not compute the multiplicity yet, because this depends on the association of the [[mass_data]] pointer. <>= procedure :: copy_from => field_data_copy_from <>= subroutine field_data_copy_from (prt, prt_src) class(field_data_t), intent(inout) :: prt class(field_data_t), intent(in) :: prt_src prt%visible = prt_src%visible prt%parton = prt_src%parton prt%gauge = prt_src%gauge prt%left_handed = prt_src%left_handed prt%right_handed = prt_src%right_handed prt%p_is_stable = prt_src%p_is_stable prt%p_decays_isotropically = prt_src%p_decays_isotropically prt%p_decays_diagonal = prt_src%p_decays_diagonal prt%p_has_decay_helicity = prt_src%p_has_decay_helicity prt%p_decay_helicity = prt_src%p_decay_helicity prt%p_decays_diagonal = prt_src%p_decays_diagonal prt%a_is_stable = prt_src%a_is_stable prt%a_decays_isotropically = prt_src%a_decays_isotropically prt%a_decays_diagonal = prt_src%a_decays_diagonal prt%a_has_decay_helicity = prt_src%a_has_decay_helicity prt%a_decay_helicity = prt_src%a_decay_helicity prt%p_polarized = prt_src%p_polarized prt%a_polarized = prt_src%a_polarized prt%spin_type = prt_src%spin_type prt%isospin_type = prt_src%isospin_type prt%charge_type = prt_src%charge_type prt%color_type = prt_src%color_type prt%has_anti = prt_src%has_anti if (allocated (prt_src%name)) then if (allocated (prt%name)) deallocate (prt%name) allocate (prt%name (size (prt_src%name)), source = prt_src%name) end if if (allocated (prt_src%anti)) then if (allocated (prt%anti)) deallocate (prt%anti) allocate (prt%anti (size (prt_src%anti)), source = prt_src%anti) end if prt%tex_name = prt_src%tex_name prt%tex_anti = prt_src%tex_anti if (allocated (prt_src%p_decay)) then if (allocated (prt%p_decay)) deallocate (prt%p_decay) allocate (prt%p_decay (size (prt_src%p_decay)), source = prt_src%p_decay) end if if (allocated (prt_src%a_decay)) then if (allocated (prt%a_decay)) deallocate (prt%a_decay) allocate (prt%a_decay (size (prt_src%a_decay)), source = prt_src%a_decay) end if end subroutine field_data_copy_from @ %def field_data_copy_from @ Set particle quantum numbers. <>= procedure :: set => field_data_set <>= subroutine field_data_set (prt, & is_visible, is_parton, is_gauge, is_left_handed, is_right_handed, & p_is_stable, p_decays_isotropically, p_decays_diagonal, & p_decay_helicity, & a_is_stable, a_decays_isotropically, a_decays_diagonal, & a_decay_helicity, & p_polarized, a_polarized, & name, anti, tex_name, tex_anti, & spin_type, isospin_type, charge_type, color_type, & mass_data, width_data, & p_decay, a_decay) class(field_data_t), intent(inout) :: prt logical, intent(in), optional :: is_visible, is_parton, is_gauge logical, intent(in), optional :: is_left_handed, is_right_handed logical, intent(in), optional :: p_is_stable logical, intent(in), optional :: p_decays_isotropically, p_decays_diagonal integer, intent(in), optional :: p_decay_helicity logical, intent(in), optional :: a_is_stable logical, intent(in), optional :: a_decays_isotropically, a_decays_diagonal integer, intent(in), optional :: a_decay_helicity logical, intent(in), optional :: p_polarized, a_polarized type(string_t), dimension(:), intent(in), optional :: name, anti type(string_t), intent(in), optional :: tex_name, tex_anti integer, intent(in), optional :: spin_type, isospin_type integer, intent(in), optional :: charge_type, color_type class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay if (present (is_visible)) prt%visible = is_visible if (present (is_parton)) prt%parton = is_parton if (present (is_gauge)) prt%gauge = is_gauge if (present (is_left_handed)) prt%left_handed = is_left_handed if (present (is_right_handed)) prt%right_handed = is_right_handed if (present (p_is_stable)) prt%p_is_stable = p_is_stable if (present (p_decays_isotropically)) & prt%p_decays_isotropically = p_decays_isotropically if (present (p_decays_diagonal)) & prt%p_decays_diagonal = p_decays_diagonal if (present (p_decay_helicity)) then prt%p_has_decay_helicity = .true. prt%p_decay_helicity = p_decay_helicity end if if (present (a_is_stable)) prt%a_is_stable = a_is_stable if (present (a_decays_isotropically)) & prt%a_decays_isotropically = a_decays_isotropically if (present (a_decays_diagonal)) & prt%a_decays_diagonal = a_decays_diagonal if (present (a_decay_helicity)) then prt%a_has_decay_helicity = .true. prt%a_decay_helicity = a_decay_helicity end if if (present (p_polarized)) prt%p_polarized = p_polarized if (present (a_polarized)) prt%a_polarized = a_polarized if (present (name)) then if (allocated (prt%name)) deallocate (prt%name) allocate (prt%name (size (name)), source = name) end if if (present (anti)) then if (allocated (prt%anti)) deallocate (prt%anti) allocate (prt%anti (size (anti)), source = anti) prt%has_anti = .true. end if if (present (tex_name)) prt%tex_name = tex_name if (present (tex_anti)) prt%tex_anti = tex_anti if (present (spin_type)) prt%spin_type = spin_type if (present (isospin_type)) prt%isospin_type = isospin_type if (present (charge_type)) prt%charge_type = charge_type if (present (color_type)) prt%color_type = color_type if (present (mass_data)) then prt%mass_data => mass_data if (associated (mass_data)) then prt%mass_val => mass_data%get_real_ptr () else prt%mass_val => null () end if end if if (present (width_data)) then prt%width_data => width_data if (associated (width_data)) then prt%width_val => width_data%get_real_ptr () else prt%width_val => null () end if end if if (present (spin_type) .or. present (mass_data)) then call prt%set_multiplicity () end if if (present (p_decay)) then if (allocated (prt%p_decay)) deallocate (prt%p_decay) if (size (p_decay) > 0) & allocate (prt%p_decay (size (p_decay)), source = p_decay) end if if (present (a_decay)) then if (allocated (prt%a_decay)) deallocate (prt%a_decay) if (size (a_decay) > 0) & allocate (prt%a_decay (size (a_decay)), source = a_decay) end if end subroutine field_data_set @ %def field_data_set @ Calculate the multiplicity given spin type and mass. <>= procedure, private :: & set_multiplicity => field_data_set_multiplicity <>= subroutine field_data_set_multiplicity (prt) class(field_data_t), intent(inout) :: prt if (prt%spin_type /= SCALAR) then if (associated (prt%mass_data)) then prt%multiplicity = prt%spin_type else if (prt%left_handed .or. prt%right_handed) then prt%multiplicity = 1 else prt%multiplicity = 2 end if end if end subroutine field_data_set_multiplicity @ %def field_data_set_multiplicity @ Set the mass/width value (not the pointer). The mass/width pointer must be allocated. <>= procedure, private :: set_mass => field_data_set_mass procedure, private :: set_width => field_data_set_width <>= subroutine field_data_set_mass (prt, mass) class(field_data_t), intent(inout) :: prt real(default), intent(in) :: mass if (associated (prt%mass_val)) prt%mass_val = mass end subroutine field_data_set_mass subroutine field_data_set_width (prt, width) class(field_data_t), intent(inout) :: prt real(default), intent(in) :: width if (associated (prt%width_val)) prt%width_val = width end subroutine field_data_set_width @ %def field_data_set_mass field_data_set_width @ Loose ends: name arrays should be allocated. <>= procedure :: freeze => field_data_freeze <>= elemental subroutine field_data_freeze (prt) class(field_data_t), intent(inout) :: prt if (.not. allocated (prt%name)) allocate (prt%name (0)) if (.not. allocated (prt%anti)) allocate (prt%anti (0)) end subroutine field_data_freeze @ %def field_data_freeze @ Output <>= procedure :: write => field_data_write <>= subroutine field_data_write (prt, unit) class(field_data_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A,1x,A)", advance="no") "particle", char (prt%longname) write (u, "(1x,I0)", advance="no") prt%pdg if (.not. prt%visible) write (u, "(2x,A)", advance="no") "invisible" if (prt%parton) write (u, "(2x,A)", advance="no") "parton" if (prt%gauge) write (u, "(2x,A)", advance="no") "gauge" if (prt%left_handed) write (u, "(2x,A)", advance="no") "left" if (prt%right_handed) write (u, "(2x,A)", advance="no") "right" write (u, *) write (u, "(5x,A)", advance="no") "name" if (allocated (prt%name)) then do i = 1, size (prt%name) write (u, "(1x,A)", advance="no") '"' // char (prt%name(i)) // '"' end do write (u, *) if (prt%has_anti) then write (u, "(5x,A)", advance="no") "anti" do i = 1, size (prt%anti) write (u, "(1x,A)", advance="no") '"' // char (prt%anti(i)) // '"' end do write (u, *) end if if (prt%tex_name /= "") then write (u, "(5x,A)") & "tex_name " // '"' // char (prt%tex_name) // '"' end if if (prt%has_anti .and. prt%tex_anti /= "") then write (u, "(5x,A)") & "tex_anti " // '"' // char (prt%tex_anti) // '"' end if else write (u, "(A)") "???" end if write (u, "(5x,A)", advance="no") "spin " select case (mod (prt%spin_type - 1, 2)) case (0); write (u, "(I0)", advance="no") (prt%spin_type-1) / 2 case default; write (u, "(I0,A)", advance="no") prt%spin_type-1, "/2" end select ! write (u, "(2x,A,I1,A)") "! [multiplicity = ", prt%multiplicity, "]" if (abs (prt%isospin_type) /= 1) then write (u, "(2x,A)", advance="no") "isospin " select case (mod (abs (prt%isospin_type) - 1, 2)) case (0); write (u, "(I0)", advance="no") & sign (abs (prt%isospin_type) - 1, prt%isospin_type) / 2 case default; write (u, "(I0,A)", advance="no") & sign (abs (prt%isospin_type) - 1, prt%isospin_type), "/2" end select end if if (abs (prt%charge_type) /= 1) then write (u, "(2x,A)", advance="no") "charge " select case (mod (abs (prt%charge_type) - 1, 3)) case (0); write (u, "(I0)", advance="no") & sign (abs (prt%charge_type) - 1, prt%charge_type) / 3 case default; write (u, "(I0,A)", advance="no") & sign (abs (prt%charge_type) - 1, prt%charge_type), "/3" end select end if if (prt%color_type /= 1) then write (u, "(2x,A,I0)", advance="no") "color ", prt%color_type end if write (u, *) if (associated (prt%mass_data)) then write (u, "(5x,A)", advance="no") & "mass " // char (prt%mass_data%get_name ()) if (associated (prt%width_data)) then write (u, "(2x,A)") & "width " // char (prt%width_data%get_name ()) else write (u, *) end if end if call prt%write_decays (u) end subroutine field_data_write @ %def field_data_write @ Write decay and polarization data. <>= procedure :: write_decays => field_data_write_decays <>= subroutine field_data_write_decays (prt, unit) class(field_data_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (.not. prt%p_is_stable) then if (allocated (prt%p_decay)) then write (u, "(5x,A)", advance="no") "p_decay" do i = 1, size (prt%p_decay) write (u, "(1x,A)", advance="no") char (prt%p_decay(i)) end do if (prt%p_decays_isotropically) then write (u, "(1x,A)", advance="no") "isotropic" else if (prt%p_decays_diagonal) then write (u, "(1x,A)", advance="no") "diagonal" else if (prt%p_has_decay_helicity) then write (u, "(1x,A,I0)", advance="no") "helicity = ", & prt%p_decay_helicity end if write (u, *) end if else if (prt%p_polarized) then write (u, "(5x,A)") "p_polarized" end if if (.not. prt%a_is_stable) then if (allocated (prt%a_decay)) then write (u, "(5x,A)", advance="no") "a_decay" do i = 1, size (prt%a_decay) write (u, "(1x,A)", advance="no") char (prt%a_decay(i)) end do if (prt%a_decays_isotropically) then write (u, "(1x,A)", advance="no") "isotropic" else if (prt%a_decays_diagonal) then write (u, "(1x,A)", advance="no") "diagonal" else if (prt%a_has_decay_helicity) then write (u, "(1x,A,I0)", advance="no") "helicity = ", & prt%a_decay_helicity end if write (u, *) end if else if (prt%a_polarized) then write (u, "(5x,A)") "a_polarized" end if end subroutine field_data_write_decays @ %def field_data_write_decays @ Screen version of output. <>= procedure :: show => field_data_show <>= subroutine field_data_show (prt, l, u) class(field_data_t), intent(in) :: prt integer, intent(in) :: l, u character(len=l) :: buffer integer :: i type(string_t), dimension(:), allocatable :: decay buffer = prt%get_name (.false.) write (u, "(4x,A,1x,I8)", advance="no") buffer, & prt%get_pdg () if (prt%is_polarized ()) then write (u, "(3x,A)") "polarized" else if (.not. prt%is_stable ()) then write (u, "(3x,A)", advance="no") "decays:" call prt%get_decays (decay) do i = 1, size (decay) write (u, "(1x,A)", advance="no") char (decay(i)) end do write (u, *) else write (u, *) end if if (prt%has_antiparticle ()) then buffer = prt%get_name (.true.) write (u, "(4x,A,1x,I8)", advance="no") buffer, & prt%get_pdg_anti () if (prt%is_polarized (.true.)) then write (u, "(3x,A)") "polarized" else if (.not. prt%is_stable (.true.)) then write (u, "(3x,A)", advance="no") "decays:" call prt%get_decays (decay, .true.) do i = 1, size (decay) write (u, "(1x,A)", advance="no") char (decay(i)) end do write (u, *) else write (u, *) end if end if end subroutine field_data_show @ %def field_data_show @ Retrieve data: <>= procedure :: get_pdg => field_data_get_pdg procedure :: get_pdg_anti => field_data_get_pdg_anti <>= elemental function field_data_get_pdg (prt) result (pdg) integer :: pdg class(field_data_t), intent(in) :: prt pdg = prt%pdg end function field_data_get_pdg elemental function field_data_get_pdg_anti (prt) result (pdg) integer :: pdg class(field_data_t), intent(in) :: prt if (prt%has_anti) then pdg = - prt%pdg else pdg = prt%pdg end if end function field_data_get_pdg_anti @ %def field_data_get_pdg field_data_get_pdg_anti @ Predicates: <>= procedure :: is_visible => field_data_is_visible procedure :: is_parton => field_data_is_parton procedure :: is_gauge => field_data_is_gauge procedure :: is_left_handed => field_data_is_left_handed procedure :: is_right_handed => field_data_is_right_handed procedure :: has_antiparticle => field_data_has_antiparticle procedure :: is_stable => field_data_is_stable procedure :: get_decays => field_data_get_decays procedure :: decays_isotropically => field_data_decays_isotropically procedure :: decays_diagonal => field_data_decays_diagonal procedure :: has_decay_helicity => field_data_has_decay_helicity procedure :: decay_helicity => field_data_decay_helicity procedure :: is_polarized => field_data_is_polarized <>= elemental function field_data_is_visible (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%visible end function field_data_is_visible elemental function field_data_is_parton (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%parton end function field_data_is_parton elemental function field_data_is_gauge (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%gauge end function field_data_is_gauge elemental function field_data_is_left_handed (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%left_handed end function field_data_is_left_handed elemental function field_data_is_right_handed (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%right_handed end function field_data_is_right_handed elemental function field_data_has_antiparticle (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%has_anti end function field_data_has_antiparticle elemental function field_data_is_stable (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_is_stable else flag = prt%p_is_stable end if else flag = prt%p_is_stable end if end function field_data_is_stable subroutine field_data_get_decays (prt, decay, anti) class(field_data_t), intent(in) :: prt type(string_t), dimension(:), intent(out), allocatable :: decay logical, intent(in), optional :: anti if (present (anti)) then if (anti) then allocate (decay (size (prt%a_decay)), source = prt%a_decay) else allocate (decay (size (prt%p_decay)), source = prt%p_decay) end if else allocate (decay (size (prt%p_decay)), source = prt%p_decay) end if end subroutine field_data_get_decays elemental function field_data_decays_isotropically & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_decays_isotropically else flag = prt%p_decays_isotropically end if else flag = prt%p_decays_isotropically end if end function field_data_decays_isotropically elemental function field_data_decays_diagonal & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_decays_diagonal else flag = prt%p_decays_diagonal end if else flag = prt%p_decays_diagonal end if end function field_data_decays_diagonal elemental function field_data_has_decay_helicity & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_has_decay_helicity else flag = prt%p_has_decay_helicity end if else flag = prt%p_has_decay_helicity end if end function field_data_has_decay_helicity elemental function field_data_decay_helicity & (prt, anti) result (hel) integer :: hel class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then hel = prt%a_decay_helicity else hel = prt%p_decay_helicity end if else hel = prt%p_decay_helicity end if end function field_data_decay_helicity elemental function field_data_is_polarized (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti logical :: a if (present (anti)) then a = anti else a = .false. end if if (a) then flag = prt%a_polarized else flag = prt%p_polarized end if end function field_data_is_polarized @ %def field_data_is_visible field_data_is_parton @ %def field_data_is_gauge @ %def field_data_is_left_handed field_data_is_right_handed @ %def field_data_has_antiparticle @ %def field_data_is_stable @ %def field_data_decays_isotropically @ %def field_data_decays_diagonal @ %def field_data_has_decay_helicity @ %def field_data_decay_helicity @ %def field_data_polarized @ Names. Return the first name in the list (or the first antiparticle name) <>= procedure :: get_longname => field_data_get_longname procedure :: get_name => field_data_get_name procedure :: get_name_array => field_data_get_name_array <>= pure function field_data_get_longname (prt) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt name = prt%longname end function field_data_get_longname pure function field_data_get_name (prt, is_antiparticle) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle name = prt%longname if (is_antiparticle) then if (prt%has_anti) then if (allocated (prt%anti)) then if (size(prt%anti) > 0) name = prt%anti(1) end if else if (allocated (prt%name)) then if (size (prt%name) > 0) name = prt%name(1) end if end if else if (allocated (prt%name)) then if (size (prt%name) > 0) name = prt%name(1) end if end if end function field_data_get_name subroutine field_data_get_name_array (prt, is_antiparticle, name) class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle type(string_t), dimension(:), allocatable, intent(inout) :: name if (allocated (name)) deallocate (name) if (is_antiparticle) then if (prt%has_anti) then allocate (name (size (prt%anti))) name = prt%anti else allocate (name (0)) end if else allocate (name (size (prt%name))) name = prt%name end if end subroutine field_data_get_name_array @ %def field_data_get_name @ Same for the \TeX\ name. <>= procedure :: get_tex_name => field_data_get_tex_name <>= elemental function field_data_get_tex_name & (prt, is_antiparticle) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle if (is_antiparticle) then if (prt%has_anti) then name = prt%tex_anti else name = prt%tex_name end if else name = prt%tex_name end if if (name == "") name = prt%get_name (is_antiparticle) end function field_data_get_tex_name @ %def field_data_get_tex_name @ Check if any of the field names matches the given string. <>= procedure, private :: matches_name => field_data_matches_name <>= function field_data_matches_name (field, name, is_antiparticle) result (flag) class(field_data_t), intent(in) :: field type(string_t), intent(in) :: name logical, intent(in) :: is_antiparticle logical :: flag if (is_antiparticle) then if (field%has_anti) then flag = any (name == field%anti) else flag = .false. end if else flag = name == field%longname .or. any (name == field%name) end if end function field_data_matches_name @ %def field_data_matches_name @ Quantum numbers <>= procedure :: get_spin_type => field_data_get_spin_type procedure :: get_multiplicity => field_data_get_multiplicity procedure :: get_isospin_type => field_data_get_isospin_type procedure :: get_charge_type => field_data_get_charge_type procedure :: get_color_type => field_data_get_color_type <>= elemental function field_data_get_spin_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%spin_type end function field_data_get_spin_type elemental function field_data_get_multiplicity (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%multiplicity end function field_data_get_multiplicity elemental function field_data_get_isospin_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%isospin_type end function field_data_get_isospin_type elemental function field_data_get_charge_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%charge_type end function field_data_get_charge_type elemental function field_data_get_color_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%color_type end function field_data_get_color_type @ %def field_data_get_spin_type @ %def field_data_get_multiplicity @ %def field_data_get_isospin_type @ %def field_data_get_charge_type @ %def field_data_get_color_type @ In the MSSM, neutralinos can have a negative mass. This is relevant for computing matrix elements. However, within the \whizard\ main program we are interested only in kinematics, therefore we return the absolute value of the particle mass. If desired, we can extract the sign separately. <>= procedure :: get_charge => field_data_get_charge procedure :: get_isospin => field_data_get_isospin procedure :: get_mass => field_data_get_mass procedure :: get_mass_sign => field_data_get_mass_sign procedure :: get_width => field_data_get_width <>= elemental function field_data_get_charge (prt) result (charge) real(default) :: charge class(field_data_t), intent(in) :: prt if (prt%charge_type /= 0) then charge = real (sign ((abs(prt%charge_type) - 1), & prt%charge_type), default) / 3 else charge = 0 end if end function field_data_get_charge elemental function field_data_get_isospin (prt) result (isospin) real(default) :: isospin class(field_data_t), intent(in) :: prt if (prt%isospin_type /= 0) then isospin = real (sign (abs(prt%isospin_type) - 1, & prt%isospin_type), default) / 2 else isospin = 0 end if end function field_data_get_isospin elemental function field_data_get_mass (prt) result (mass) real(default) :: mass class(field_data_t), intent(in) :: prt if (associated (prt%mass_val)) then mass = abs (prt%mass_val) else mass = 0 end if end function field_data_get_mass elemental function field_data_get_mass_sign (prt) result (sgn) integer :: sgn class(field_data_t), intent(in) :: prt if (associated (prt%mass_val)) then sgn = sign (1._default, prt%mass_val) else sgn = 0 end if end function field_data_get_mass_sign elemental function field_data_get_width (prt) result (width) real(default) :: width class(field_data_t), intent(in) :: prt if (associated (prt%width_val)) then width = prt%width_val else width = 0 end if end function field_data_get_width @ %def field_data_get_charge field_data_get_isospin @ %def field_data_get_mass field_data_get_mass_sign @ %def field_data_get_width @ Find the [[model]] containing the [[PDG]] given two model files. <>= public :: find_model <>= subroutine find_model (model, PDG, model_A, model_B) class(model_data_t), pointer, intent(out) :: model integer, intent(in) :: PDG class(model_data_t), intent(in), target :: model_A, model_B character(len=10) :: buffer if (model_A%test_field (PDG)) then model => model_A else if (model_B%test_field (PDG)) then model => model_B else call model_A%write () call model_B%write () write (buffer, "(I10)") PDG call msg_fatal ("Parton " // buffer // & " not found in the given model files") end if end subroutine find_model @ %def find_model @ \subsection{Vertex data} The vertex object contains an array of particle-data pointers, for which we need a separate type. (We could use the flavor type defined in another module.) The program does not (yet?) make use of vertex definitions, so they are not stored here. <>= type :: field_data_p type(field_data_t), pointer :: p => null () end type field_data_p @ %def field_data_p <>= type :: vertex_t private logical :: trilinear integer, dimension(:), allocatable :: pdg type(field_data_p), dimension(:), allocatable :: prt contains <> end type vertex_t @ %def vertex_t <>= procedure :: write => vertex_write <>= subroutine vertex_write (vtx, unit) class(vertex_t), intent(in) :: vtx integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(3x,A)", advance="no") "vertex" do i = 1, size (vtx%prt) if (associated (vtx%prt(i)%p)) then write (u, "(1x,A)", advance="no") & '"' // char (vtx%prt(i)%p%get_name (vtx%pdg(i) < 0)) & // '"' else write (u, "(1x,I7)", advance="no") vtx%pdg(i) end if end do write (u, *) end subroutine vertex_write @ %def vertex_write @ Initialize using PDG codes. The model is used for finding particle data pointers associated with the pdg codes. <>= procedure :: init => vertex_init <>= subroutine vertex_init (vtx, pdg, model) class(vertex_t), intent(out) :: vtx integer, dimension(:), intent(in) :: pdg type(model_data_t), intent(in), target, optional :: model integer :: i allocate (vtx%pdg (size (pdg))) allocate (vtx%prt (size (pdg))) vtx%trilinear = size (pdg) == 3 vtx%pdg = pdg if (present (model)) then do i = 1, size (pdg) vtx%prt(i)%p => model%get_field_ptr (pdg(i)) end do end if end subroutine vertex_init @ %def vertex_init @ Copy vertex: we must reassign the field-data pointer to a new model. <>= procedure :: copy_from => vertex_copy_from <>= subroutine vertex_copy_from (vtx, old_vtx, new_model) class(vertex_t), intent(out) :: vtx class(vertex_t), intent(in) :: old_vtx type(model_data_t), intent(in), target, optional :: new_model call vtx%init (old_vtx%pdg, new_model) end subroutine vertex_copy_from @ %def vertex_copy_from @ Single-particle lookup: Given a particle code, we return matching codes if present, otherwise zero. Actually, we return the antiparticles of the matching codes, as appropriate for computing splittings. <>= procedure :: get_match => vertex_get_match <>= subroutine vertex_get_match (vtx, pdg1, pdg2) class(vertex_t), intent(in) :: vtx integer, intent(in) :: pdg1 integer, dimension(:), allocatable, intent(out) :: pdg2 integer :: i, j do i = 1, size (vtx%pdg) if (vtx%pdg(i) == pdg1) then allocate (pdg2 (size (vtx%pdg) - 1)) do j = 1, i-1 pdg2(j) = anti (j) end do do j = i, size (pdg2) pdg2(j) = anti (j+1) end do exit end if end do contains function anti (i) result (pdg) integer, intent(in) :: i integer :: pdg if (vtx%prt(i)%p%has_antiparticle ()) then pdg = - vtx%pdg(i) else pdg = vtx%pdg(i) end if end function anti end subroutine vertex_get_match @ %def vertex_get_match @ To access this from the outside, we create an iterator. The iterator has the sole purpose of returning the matching particles for a given array of PDG codes. <>= public :: vertex_iterator_t <>= type :: vertex_iterator_t private class(model_data_t), pointer :: model => null () integer, dimension(:), allocatable :: pdg integer :: vertex_index = 0 integer :: pdg_index = 0 logical :: save_pdg_index contains procedure :: init => vertex_iterator_init procedure :: get_next_match => vertex_iterator_get_next_match end type vertex_iterator_t @ %def vertex_iterator_t @ We initialize the iterator for a particular model with the [[pdg]] index of the particle we are looking at. <>= subroutine vertex_iterator_init (it, model, pdg, save_pdg_index) class(vertex_iterator_t), intent(out) :: it class(model_data_t), intent(in), target :: model integer, dimension(:), intent(in) :: pdg logical, intent(in) :: save_pdg_index it%model => model allocate (it%pdg (size (pdg)), source = pdg) it%save_pdg_index = save_pdg_index end subroutine vertex_iterator_init subroutine vertex_iterator_get_next_match (it, pdg_match) class(vertex_iterator_t), intent(inout) :: it integer, dimension(:), allocatable, intent(out) :: pdg_match integer :: i, j do i = it%vertex_index + 1, size (it%model%vtx) do j = it%pdg_index + 1, size (it%pdg) call it%model%vtx(i)%get_match (it%pdg(j), pdg_match) if (it%save_pdg_index) then if (allocated (pdg_match) .and. j < size (it%pdg)) then it%pdg_index = j return else if (allocated (pdg_match) .and. j == size (it%pdg)) then it%vertex_index = i it%pdg_index = 0 return end if else if (allocated (pdg_match)) then it%vertex_index = i return end if end do end do it%vertex_index = 0 it%pdg_index = 0 end subroutine vertex_iterator_get_next_match @ %def vertex_iterator_get_next_match @ \subsection{Vertex lookup table} The vertex lookup table is a hash table: given two particle codes, we check which codes are allowed for the third one. The size of the hash table should be large enough that collisions are rare. We first select a size based on the number of vertices (multiplied by six because all permutations count), with some margin, and then choose the smallest integer power of two larger than this. <>= integer, parameter :: VERTEX_TABLE_SCALE_FACTOR = 60 @ %def VERTEX_TABLE_SCALE_FACTOR <>= function vertex_table_size (n_vtx) result (n) integer(i32) :: n integer, intent(in) :: n_vtx integer :: i, s s = VERTEX_TABLE_SCALE_FACTOR * n_vtx n = 1 do i = 1, 31 n = ishft (n, 1) s = ishft (s,-1) if (s == 0) exit end do end function vertex_table_size @ %def vertex_table_size @ The specific hash function takes two particle codes (arbitrary integers) and returns a 32-bit integer. It makes use of the universal function [[hash]] which operates on a byte array. <>= function hash2 (pdg1, pdg2) integer(i32) :: hash2 integer, intent(in) :: pdg1, pdg2 integer(i8), dimension(1) :: mold hash2 = hash (transfer ([pdg1, pdg2], mold)) end function hash2 @ %def hash2 @ Each entry in the vertex table stores the two particle codes and an array of possibilities for the third code. <>= type :: vertex_table_entry_t private integer :: pdg1 = 0, pdg2 = 0 integer :: n = 0 integer, dimension(:), allocatable :: pdg3 end type vertex_table_entry_t @ %def vertex_table_entry_t @ The vertex table: <>= type :: vertex_table_t type(vertex_table_entry_t), dimension(:), allocatable :: entry integer :: n_collisions = 0 integer(i32) :: mask contains <> end type vertex_table_t @ %def vertex_table_t @ Output. <>= procedure :: write => vertex_table_write <>= subroutine vertex_table_write (vt, unit) class(vertex_table_t), intent(in) :: vt integer, intent(in), optional :: unit integer :: u, i character(9) :: size_pdg3 u = given_output_unit (unit) write (u, "(A)") "vertex hash table:" write (u, "(A,I7)") " size = ", size (vt%entry) write (u, "(A,I7)") " used = ", count (vt%entry%n /= 0) write (u, "(A,I7)") " coll = ", vt%n_collisions do i = lbound (vt%entry, 1), ubound (vt%entry, 1) if (vt%entry(i)%n /= 0) then write (size_pdg3, "(I7)") size (vt%entry(i)%pdg3) write (u, "(A,1x,I7,1x,A,2(1x,I7),A," // & size_pdg3 // "(1x,I7))") & " ", i, ":", vt%entry(i)%pdg1, & vt%entry(i)%pdg2, "->", vt%entry(i)%pdg3 end if end do end subroutine vertex_table_write @ %def vertex_table_write @ Initializing the vertex table: This is done in two passes. First, we scan all permutations for all vertices and count the number of entries in each bucket of the hashtable. Then, the buckets are allocated accordingly and filled. Collision resolution is done by just incrementing the hash value until an empty bucket is found. The vertex table size is fixed, since we know from the beginning the number of entries. <>= procedure :: init => vertex_table_init <>= subroutine vertex_table_init (vt, prt, vtx) class(vertex_table_t), intent(out) :: vt type(field_data_t), dimension(:), intent(in) :: prt type(vertex_t), dimension(:), intent(in) :: vtx integer :: n_vtx, vt_size, i, p1, p2, p3 integer, dimension(3) :: p n_vtx = size (vtx) vt_size = vertex_table_size (count (vtx%trilinear)) vt%mask = vt_size - 1 allocate (vt%entry (0:vt_size-1)) do i = 1, n_vtx if (vtx(i)%trilinear) then p = vtx(i)%pdg p1 = p(1); p2 = p(2) call create (hash2 (p1, p2)) if (p(2) /= p(3)) then p2 = p(3) call create (hash2 (p1, p2)) end if if (p(1) /= p(2)) then p1 = p(2); p2 = p(1) call create (hash2 (p1, p2)) if (p(1) /= p(3)) then p2 = p(3) call create (hash2 (p1, p2)) end if end if if (p(1) /= p(3)) then p1 = p(3); p2 = p(1) call create (hash2 (p1, p2)) if (p(1) /= p(2)) then p2 = p(2) call create (hash2 (p1, p2)) end if end if end if end do do i = 0, vt_size - 1 allocate (vt%entry(i)%pdg3 (vt%entry(i)%n)) end do vt%entry%n = 0 do i = 1, n_vtx if (vtx(i)%trilinear) then p = vtx(i)%pdg p1 = p(1); p2 = p(2); p3 = p(3) call register (hash2 (p1, p2)) if (p(2) /= p(3)) then p2 = p(3); p3 = p(2) call register (hash2 (p1, p2)) end if if (p(1) /= p(2)) then p1 = p(2); p2 = p(1); p3 = p(3) call register (hash2 (p1, p2)) if (p(1) /= p(3)) then p2 = p(3); p3 = p(1) call register (hash2 (p1, p2)) end if end if if (p(1) /= p(3)) then p1 = p(3); p2 = p(1); p3 = p(2) call register (hash2 (p1, p2)) if (p(1) /= p(2)) then p2 = p(2); p3 = p(1) call register (hash2 (p1, p2)) end if end if end if end do contains recursive subroutine create (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then vt%entry(h)%pdg1 = p1 vt%entry(h)%pdg2 = p2 vt%entry(h)%n = 1 else if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then vt%entry(h)%n = vt%entry(h)%n + 1 else vt%n_collisions = vt%n_collisions + 1 call create (hashval + 1) end if end subroutine create recursive subroutine register (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then vt%entry(h)%n = vt%entry(h)%n + 1 vt%entry(h)%pdg3(vt%entry(h)%n) = p3 else call register (hashval + 1) end if end subroutine register end subroutine vertex_table_init @ %def vertex_table_init @ Return the array of particle codes that match the given pair. <>= procedure :: match => vertex_table_match <>= subroutine vertex_table_match (vt, pdg1, pdg2, pdg3) class(vertex_table_t), intent(in) :: vt integer, intent(in) :: pdg1, pdg2 integer, dimension(:), allocatable, intent(out) :: pdg3 call match (hash2 (pdg1, pdg2)) contains recursive subroutine match (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then allocate (pdg3 (0)) else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then allocate (pdg3 (size (vt%entry(h)%pdg3))) pdg3 = vt%entry(h)%pdg3 else call match (hashval + 1) end if end subroutine match end subroutine vertex_table_match @ %def vertex_table_match @ Return true if the triplet is represented as a vertex. <>= procedure :: check => vertex_table_check <>= function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag) class(vertex_table_t), intent(in) :: vt integer, intent(in) :: pdg1, pdg2, pdg3 logical :: flag flag = check (hash2 (pdg1, pdg2)) contains recursive function check (hashval) result (flag) integer(i32), intent(in) :: hashval integer :: h logical :: flag h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then flag = .false. else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then flag = any (vt%entry(h)%pdg3 == pdg3) else flag = check (hashval + 1) end if end function check end function vertex_table_check @ %def vertex_table_check @ \subsection{Model Data Record} This type collects the model data as defined above. We deliberately implement the parameter arrays as pointer arrays. We thus avoid keeping track of TARGET attributes. The [[scheme]] identifier provides meta information. It doesn't give the client code an extra parameter, but it tells something about the interpretation of the parameters. If the scheme ID is left as default (zero), it is ignored. <>= public :: model_data_t <>= type :: model_data_t private type(string_t) :: name integer :: scheme = 0 type(modelpar_real_t), dimension(:), pointer :: par_real => null () type(modelpar_complex_t), dimension(:), pointer :: par_complex => null () type(field_data_t), dimension(:), allocatable :: field type(vertex_t), dimension(:), allocatable :: vtx type(vertex_table_t) :: vt contains <> end type model_data_t @ %def model_data_t @ Finalizer, deallocate pointer arrays. <>= procedure :: final => model_data_final <>= subroutine model_data_final (model) class(model_data_t), intent(inout) :: model if (associated (model%par_real)) then deallocate (model%par_real) end if if (associated (model%par_complex)) then deallocate (model%par_complex) end if end subroutine model_data_final @ %def model_data_final @ Output. The signature matches the signature of the high-level [[model_write]] procedure, so some of the options don't actually apply. <>= procedure :: write => model_data_write <>= subroutine model_data_write (model, unit, verbose, & show_md5sum, show_variables, show_parameters, & show_particles, show_vertices, show_scheme) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: show_md5sum logical, intent(in), optional :: show_variables logical, intent(in), optional :: show_parameters logical, intent(in), optional :: show_particles logical, intent(in), optional :: show_vertices logical, intent(in), optional :: show_scheme logical :: show_sch, show_par, show_prt, show_vtx integer :: u, i u = given_output_unit (unit) show_sch = .false.; if (present (show_scheme)) & show_sch = show_scheme show_par = .true.; if (present (show_parameters)) & show_par = show_parameters show_prt = .true.; if (present (show_particles)) & show_prt = show_particles show_vtx = .true.; if (present (show_vertices)) & show_vtx = show_vertices if (show_sch) then write (u, "(3x,A,1X,I0)") "scheme =", model%scheme end if if (show_par) then do i = 1, size (model%par_real) call model%par_real(i)%write (u) write (u, "(A)") end do do i = 1, size (model%par_complex) call model%par_complex(i)%write (u) write (u, "(A)") end do end if if (show_prt) then write (u, "(A)") call model%write_fields (u) end if if (show_vtx) then write (u, "(A)") call model%write_vertices (u, verbose) end if end subroutine model_data_write @ %def model_data_write @ Initialize, allocating pointer arrays. The second version makes a deep copy. <>= generic :: init => model_data_init procedure, private :: model_data_init <>= subroutine model_data_init (model, name, & n_par_real, n_par_complex, n_field, n_vtx) class(model_data_t), intent(out) :: model type(string_t), intent(in) :: name integer, intent(in) :: n_par_real, n_par_complex integer, intent(in) :: n_field integer, intent(in) :: n_vtx model%name = name allocate (model%par_real (n_par_real)) allocate (model%par_complex (n_par_complex)) allocate (model%field (n_field)) allocate (model%vtx (n_vtx)) end subroutine model_data_init @ %def model_data_init @ Set the scheme ID. <>= procedure :: set_scheme_num => model_data_set_scheme_num <>= subroutine model_data_set_scheme_num (model, scheme) class(model_data_t), intent(inout) :: model integer, intent(in) :: scheme model%scheme = scheme end subroutine model_data_set_scheme_num @ %def model_data_set_scheme_num @ Complete model data initialization. <>= procedure :: freeze_fields => model_data_freeze_fields <>= subroutine model_data_freeze_fields (model) class(model_data_t), intent(inout) :: model call model%field%freeze () end subroutine model_data_freeze_fields @ %def model_data_freeze @ Deep copy. The new model should already be initialized, so we do not allocate memory. <>= procedure :: copy_from => model_data_copy <>= subroutine model_data_copy (model, src) class(model_data_t), intent(inout), target :: model class(model_data_t), intent(in), target :: src class(modelpar_data_t), pointer :: data, src_data integer :: i model%scheme = src%scheme model%par_real = src%par_real model%par_complex = src%par_complex do i = 1, size (src%field) associate (field => model%field(i), src_field => src%field(i)) call field%init (src_field%get_longname (), src_field%get_pdg ()) call field%copy_from (src_field) src_data => src_field%mass_data if (associated (src_data)) then data => model%get_par_data_ptr (src_data%get_name ()) call field%set (mass_data = data) end if src_data => src_field%width_data if (associated (src_data)) then data => model%get_par_data_ptr (src_data%get_name ()) call field%set (width_data = data) end if call field%set_multiplicity () end associate end do do i = 1, size (src%vtx) call model%vtx(i)%copy_from (src%vtx(i), model) end do call model%freeze_vertices () end subroutine model_data_copy @ %def model_data_copy @ Return the model name and numeric scheme. <>= procedure :: get_name => model_data_get_name procedure :: get_scheme_num => model_data_get_scheme_num <>= function model_data_get_name (model) result (name) class(model_data_t), intent(in) :: model type(string_t) :: name name = model%name end function model_data_get_name function model_data_get_scheme_num (model) result (scheme) class(model_data_t), intent(in) :: model integer :: scheme scheme = model%scheme end function model_data_get_scheme_num @ %def model_data_get_name @ %def model_data_get_scheme @ Retrieve a MD5 sum for the current model parameter values and decay/polarization settings. This is done by writing them to a temporary file, using a standard format. If the model scheme is nonzero, it is also written. <>= procedure :: get_parameters_md5sum => model_data_get_parameters_md5sum <>= function model_data_get_parameters_md5sum (model) result (par_md5sum) character(32) :: par_md5sum class(model_data_t), intent(in) :: model real(default), dimension(:), allocatable :: par type(field_data_t), pointer :: field integer :: unit, i allocate (par (model%get_n_real ())) call model%real_parameters_to_array (par) unit = free_unit () open (unit, status="scratch", action="readwrite") if (model%scheme /= 0) write (unit, "(I0)") model%scheme write (unit, "(" // FMT_19 // ")") par do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_stable (.false.) .or. .not. field%is_stable (.true.) & .or. field%is_polarized (.false.) .or. field%is_polarized (.true.))& then write (unit, "(3x,A)") char (field%get_longname ()) call field%write_decays (unit) end if end do rewind (unit) par_md5sum = md5sum (unit) close (unit) end function model_data_get_parameters_md5sum @ %def model_get_parameters_md5sum @ Return the MD5 sum. This is a placeholder, to be overwritten for the complete model definition. <>= procedure :: get_md5sum => model_data_get_md5sum <>= function model_data_get_md5sum (model) result (md5sum) class(model_data_t), intent(in) :: model character(32) :: md5sum md5sum = model%get_parameters_md5sum () end function model_data_get_md5sum @ %def model_data_get_md5sum @ Initialize a real or complex parameter. <>= generic :: init_par => model_data_init_par_real, model_data_init_par_complex procedure, private :: model_data_init_par_real procedure, private :: model_data_init_par_complex <>= subroutine model_data_init_par_real (model, i, name, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: i type(string_t), intent(in) :: name real(default), intent(in) :: value call model%par_real(i)%init (name, value) end subroutine model_data_init_par_real subroutine model_data_init_par_complex (model, i, name, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: i type(string_t), intent(in) :: name complex(default), intent(in) :: value call model%par_complex(i)%init (name, value) end subroutine model_data_init_par_complex @ %def model_data_init_par_real model_data_init_par_complex @ After initialization, return size of parameter array. <>= procedure :: get_n_real => model_data_get_n_real procedure :: get_n_complex => model_data_get_n_complex <>= function model_data_get_n_real (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%par_real) end function model_data_get_n_real function model_data_get_n_complex (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%par_complex) end function model_data_get_n_complex @ %def model_data_get_n_real @ %def model_data_get_n_complex @ After initialization, extract the whole parameter array. <>= procedure :: real_parameters_to_array & => model_data_real_par_to_array procedure :: complex_parameters_to_array & => model_data_complex_par_to_array <>= subroutine model_data_real_par_to_array (model, array) class(model_data_t), intent(in) :: model real(default), dimension(:), intent(inout) :: array array = model%par_real%get_real () end subroutine model_data_real_par_to_array subroutine model_data_complex_par_to_array (model, array) class(model_data_t), intent(in) :: model complex(default), dimension(:), intent(inout) :: array array = model%par_complex%get_complex () end subroutine model_data_complex_par_to_array @ %def model_data_real_par_to_array @ %def model_data_complex_par_to_array @ After initialization, set the whole parameter array. <>= procedure :: real_parameters_from_array & => model_data_real_par_from_array procedure :: complex_parameters_from_array & => model_data_complex_par_from_array <>= subroutine model_data_real_par_from_array (model, array) class(model_data_t), intent(inout) :: model real(default), dimension(:), intent(in) :: array model%par_real = array end subroutine model_data_real_par_from_array subroutine model_data_complex_par_from_array (model, array) class(model_data_t), intent(inout) :: model complex(default), dimension(:), intent(in) :: array model%par_complex = array end subroutine model_data_complex_par_from_array @ %def model_data_real_par_from_array @ %def model_data_complex_par_from_array @ Analogous, for a C parameter array. <>= procedure :: real_parameters_to_c_array & => model_data_real_par_to_c_array <>= subroutine model_data_real_par_to_c_array (model, array) class(model_data_t), intent(in) :: model real(c_default_float), dimension(:), intent(inout) :: array array = model%par_real%get_real () end subroutine model_data_real_par_to_c_array @ %def model_data_real_par_to_c_array @ After initialization, set the whole parameter array. <>= procedure :: real_parameters_from_c_array & => model_data_real_par_from_c_array <>= subroutine model_data_real_par_from_c_array (model, array) class(model_data_t), intent(inout) :: model real(c_default_float), dimension(:), intent(in) :: array model%par_real = real (array, default) end subroutine model_data_real_par_from_c_array @ %def model_data_real_par_from_c_array @ After initialization, get pointer to a real or complex parameter, directly by index. <>= procedure :: get_par_real_ptr => model_data_get_par_real_ptr_index procedure :: get_par_complex_ptr => model_data_get_par_complex_ptr_index <>= function model_data_get_par_real_ptr_index (model, i) result (ptr) class(model_data_t), intent(inout) :: model integer, intent(in) :: i class(modelpar_data_t), pointer :: ptr ptr => model%par_real(i) end function model_data_get_par_real_ptr_index function model_data_get_par_complex_ptr_index (model, i) result (ptr) class(model_data_t), intent(inout) :: model integer, intent(in) :: i class(modelpar_data_t), pointer :: ptr ptr => model%par_complex(i) end function model_data_get_par_complex_ptr_index @ %def model_data_get_par_real_ptr model_data_get_par_complex_ptr @ After initialization, get pointer to a parameter by name. <>= procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name <>= function model_data_get_par_data_ptr_name (model, name) result (ptr) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: ptr integer :: i do i = 1, size (model%par_real) if (model%par_real(i)%name == name) then ptr => model%par_real(i) return end if end do do i = 1, size (model%par_complex) if (model%par_complex(i)%name == name) then ptr => model%par_complex(i) return end if end do ptr => null () end function model_data_get_par_data_ptr_name @ %def model_data_get_par_data_ptr @ Return the value by name. Again, type conversion is allowed. <>= procedure :: get_real => model_data_get_par_real_value procedure :: get_complex => model_data_get_par_complex_value <>= function model_data_get_par_real_value (model, name) result (value) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par real(default) :: value par => model%get_par_data_ptr (name) value = par%get_real () end function model_data_get_par_real_value function model_data_get_par_complex_value (model, name) result (value) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par complex(default) :: value par => model%get_par_data_ptr (name) value = par%get_complex () end function model_data_get_par_complex_value @ %def model_data_get_real @ %def model_data_get_complex @ Modify a real or complex parameter. <>= generic :: set_par => model_data_set_par_real, model_data_set_par_complex procedure, private :: model_data_set_par_real procedure, private :: model_data_set_par_complex <>= subroutine model_data_set_par_real (model, name, value) class(model_data_t), intent(inout) :: model type(string_t), intent(in) :: name real(default), intent(in) :: value class(modelpar_data_t), pointer :: par par => model%get_par_data_ptr (name) par = value end subroutine model_data_set_par_real subroutine model_data_set_par_complex (model, name, value) class(model_data_t), intent(inout) :: model type(string_t), intent(in) :: name complex(default), intent(in) :: value class(modelpar_data_t), pointer :: par par => model%get_par_data_ptr (name) par = value end subroutine model_data_set_par_complex @ %def model_data_set_par_real model_data_set_par_complex @ List all fields in the model. <>= procedure :: write_fields => model_data_write_fields <>= subroutine model_data_write_fields (model, unit) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit integer :: i do i = 1, size (model%field) call model%field(i)%write (unit) end do end subroutine model_data_write_fields @ %def model_data_write_fields @ After initialization, return number of fields (particles): <>= procedure :: get_n_field => model_data_get_n_field <>= function model_data_get_n_field (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%field) end function model_data_get_n_field @ %def model_data_get_n_field @ Return the PDG code of a field. The field is identified by name or by index. If the field is not found, return zero. <>= generic :: get_pdg => & model_data_get_field_pdg_index, & model_data_get_field_pdg_name procedure, private :: model_data_get_field_pdg_index procedure, private :: model_data_get_field_pdg_name <>= function model_data_get_field_pdg_index (model, i) result (pdg) class(model_data_t), intent(in) :: model integer, intent(in) :: i integer :: pdg pdg = model%field(i)%get_pdg () end function model_data_get_field_pdg_index function model_data_get_field_pdg_name (model, name, check) result (pdg) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name logical, intent(in), optional :: check integer :: pdg integer :: i do i = 1, size (model%field) associate (field => model%field(i)) if (field%matches_name (name, .false.)) then pdg = field%get_pdg () return else if (field%matches_name (name, .true.)) then pdg = - field%get_pdg () return end if end associate end do pdg = 0 call model%field_error (check, name) end function model_data_get_field_pdg_name @ %def model_data_get_field_pdg @ Return an array of all PDG codes, including antiparticles. The antiparticle are sorted after all particles. <>= procedure :: get_all_pdg => model_data_get_all_pdg <>= subroutine model_data_get_all_pdg (model, pdg) class(model_data_t), intent(in) :: model integer, dimension(:), allocatable, intent(inout) :: pdg integer :: n0, n1, i, k n0 = size (model%field) n1 = n0 + count (model%field%has_antiparticle ()) allocate (pdg (n1)) pdg(1:n0) = model%field%get_pdg () k = n0 do i = 1, size (model%field) associate (field => model%field(i)) if (field%has_antiparticle ()) then k = k + 1 pdg(k) = - field%get_pdg () end if end associate end do end subroutine model_data_get_all_pdg @ %def model_data_get_all_pdg @ Return pointer to the field array. <>= procedure :: get_field_array_ptr => model_data_get_field_array_ptr <>= function model_data_get_field_array_ptr (model) result (ptr) class(model_data_t), intent(in), target :: model type(field_data_t), dimension(:), pointer :: ptr ptr => model%field end function model_data_get_field_array_ptr @ %def model_data_get_field_array_ptr @ Return pointer to a field. The identifier should be the unique long name, the PDG code, or the index. We can issue an error message, if the [[check]] flag is set. We never return an error if the PDG code is zero, this yields just a null pointer. <>= generic :: get_field_ptr => & model_data_get_field_ptr_name, & model_data_get_field_ptr_pdg procedure, private :: model_data_get_field_ptr_name procedure, private :: model_data_get_field_ptr_pdg procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index <>= function model_data_get_field_ptr_name (model, name, check) result (ptr) class(model_data_t), intent(in), target :: model type(string_t), intent(in) :: name logical, intent(in), optional :: check type(field_data_t), pointer :: ptr integer :: i do i = 1, size (model%field) if (model%field(i)%matches_name (name, .false.)) then ptr => model%field(i) return else if (model%field(i)%matches_name (name, .true.)) then ptr => model%field(i) return end if end do ptr => null () call model%field_error (check, name) end function model_data_get_field_ptr_name function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr) class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg logical, intent(in), optional :: check type(field_data_t), pointer :: ptr integer :: i, pdg_abs if (pdg == 0) then ptr => null () return end if pdg_abs = abs (pdg) do i = 1, size (model%field) if (model%field(i)%get_pdg () == pdg_abs) then ptr => model%field(i) return end if end do ptr => null () call model%field_error (check, pdg=pdg) end function model_data_get_field_ptr_pdg function model_data_get_field_ptr_index (model, i) result (ptr) class(model_data_t), intent(in), target :: model integer, intent(in) :: i type(field_data_t), pointer :: ptr ptr => model%field(i) end function model_data_get_field_ptr_index @ %def model_data_get_field_ptr @ Don't assign a pointer, just check. <>= procedure :: test_field => model_data_test_field_pdg <>= function model_data_test_field_pdg (model, pdg, check) result (exist) class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg logical, intent(in), optional :: check logical :: exist exist = associated (model%get_field_ptr (pdg, check)) end function model_data_test_field_pdg @ %def model_data_test_field_pdg @ Error message, if [[check]] is set. <>= procedure :: field_error => model_data_field_error <>= subroutine model_data_field_error (model, check, name, pdg) class(model_data_t), intent(in) :: model logical, intent(in), optional :: check type(string_t), intent(in), optional :: name integer, intent(in), optional :: pdg if (present (check)) then if (check) then if (present (name)) then write (msg_buffer, "(A,1x,A,1x,A,1x,A)") & "No particle with name", char (name), & "is contained in model", char (model%name) else if (present (pdg)) then write (msg_buffer, "(A,1x,I0,1x,A,1x,A)") & "No particle with PDG code", pdg, & "is contained in model", char (model%name) else write (msg_buffer, "(A,1x,A,1x,A)") & "Particle missing", & "in model", char (model%name) end if call msg_fatal () end if end if end subroutine model_data_field_error @ %def model_data_field_error @ Assign mass and width value, which are associated via pointer. Identify the particle via pdg. <>= procedure :: set_field_mass => model_data_set_field_mass_pdg procedure :: set_field_width => model_data_set_field_width_pdg <>= subroutine model_data_set_field_mass_pdg (model, pdg, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: pdg real(default), intent(in) :: value type(field_data_t), pointer :: field field => model%get_field_ptr (pdg, check = .true.) call field%set_mass (value) end subroutine model_data_set_field_mass_pdg subroutine model_data_set_field_width_pdg (model, pdg, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: pdg real(default), intent(in) :: value type(field_data_t), pointer :: field field => model%get_field_ptr (pdg, check = .true.) call field%set_width (value) end subroutine model_data_set_field_width_pdg @ %def model_data_set_field_mass @ %def model_data_set_field_width @ Mark a particle as unstable and provide a list of names for its decay processes. In contrast with the previous subroutine which is for internal use, we address the particle by its PDG code. If the index is negative, we address the antiparticle. <>= procedure :: set_unstable => model_data_set_unstable procedure :: set_stable => model_data_set_stable <>= subroutine model_data_set_unstable & (model, pdg, decay, isotropic, diagonal, decay_helicity) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(string_t), dimension(:), intent(in) :: decay logical, intent(in), optional :: isotropic, diagonal integer, intent(in), optional :: decay_helicity type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set ( & p_is_stable = .false., p_decay = decay, & p_decays_isotropically = isotropic, & p_decays_diagonal = diagonal, & p_decay_helicity = decay_helicity) else call field%set ( & a_is_stable = .false., a_decay = decay, & a_decays_isotropically = isotropic, & a_decays_diagonal = diagonal, & a_decay_helicity = decay_helicity) end if end subroutine model_data_set_unstable subroutine model_data_set_stable (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_is_stable = .true.) else call field%set (a_is_stable = .true.) end if end subroutine model_data_set_stable @ %def model_data_set_unstable @ %def model_data_set_stable @ Mark a particle as polarized. <>= procedure :: set_polarized => model_data_set_polarized procedure :: set_unpolarized => model_data_set_unpolarized <>= subroutine model_data_set_polarized (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_polarized = .true.) else call field%set (a_polarized = .true.) end if end subroutine model_data_set_polarized subroutine model_data_set_unpolarized (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_polarized = .false.) else call field%set (a_polarized = .false.) end if end subroutine model_data_set_unpolarized @ %def model_data_set_polarized @ %def model_data_set_unpolarized @ Revert all polarized (unstable) particles to unpolarized (stable) status, respectively. <>= procedure :: clear_unstable => model_clear_unstable procedure :: clear_polarized => model_clear_polarized <>= subroutine model_clear_unstable (model) class(model_data_t), intent(inout), target :: model integer :: i type(field_data_t), pointer :: field do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%set (p_is_stable = .true.) if (field%has_antiparticle ()) then call field%set (a_is_stable = .true.) end if end do end subroutine model_clear_unstable subroutine model_clear_polarized (model) class(model_data_t), intent(inout), target :: model integer :: i type(field_data_t), pointer :: field do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%set (p_polarized = .false.) if (field%has_antiparticle ()) then call field%set (a_polarized = .false.) end if end do end subroutine model_clear_polarized @ %def model_clear_unstable @ %def model_clear_polarized @ List all vertices, optionally also the hash table. <>= procedure :: write_vertices => model_data_write_vertices <>= subroutine model_data_write_vertices (model, unit, verbose) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: i, u u = given_output_unit (unit) do i = 1, size (model%vtx) call vertex_write (model%vtx(i), unit) end do if (present (verbose)) then if (verbose) then write (u, *) call vertex_table_write (model%vt, unit) end if end if end subroutine model_data_write_vertices @ %def model_data_write_vertices @ Vertex definition. <>= generic :: set_vertex => & model_data_set_vertex_pdg, model_data_set_vertex_names procedure, private :: model_data_set_vertex_pdg procedure, private :: model_data_set_vertex_names <>= subroutine model_data_set_vertex_pdg (model, i, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg call vertex_init (model%vtx(i), pdg, model) end subroutine model_data_set_vertex_pdg subroutine model_data_set_vertex_names (model, i, name) class(model_data_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), dimension(:), intent(in) :: name integer, dimension(size(name)) :: pdg integer :: j do j = 1, size (name) pdg(j) = model%get_pdg (name(j)) end do call model%set_vertex (i, pdg) end subroutine model_data_set_vertex_names @ %def model_data_set_vertex @ Finalize vertex definition: set up the hash table. <>= procedure :: freeze_vertices => model_data_freeze_vertices <>= subroutine model_data_freeze_vertices (model) class(model_data_t), intent(inout) :: model call model%vt%init (model%field, model%vtx) end subroutine model_data_freeze_vertices @ %def model_data_freeze_vertices @ Number of vertices in model <>= procedure :: get_n_vtx => model_data_get_n_vtx <>= function model_data_get_n_vtx (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%vtx) end function model_data_get_n_vtx @ %def model_data_get_n_vtx @ Lookup functions <>= procedure :: match_vertex => model_data_match_vertex <>= subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3) class(model_data_t), intent(in) :: model integer, intent(in) :: pdg1, pdg2 integer, dimension(:), allocatable, intent(out) :: pdg3 call model%vt%match (pdg1, pdg2, pdg3) end subroutine model_data_match_vertex @ %def model_data_match_vertex <>= procedure :: check_vertex => model_data_check_vertex <>= function model_data_check_vertex (model, pdg1, pdg2, pdg3) result (flag) logical :: flag class(model_data_t), intent(in) :: model integer, intent(in) :: pdg1, pdg2, pdg3 flag = model%vt%check (pdg1, pdg2, pdg3) end function model_data_check_vertex @ %def model_data_check_vertex @ \subsection{Toy Models} This is a stripped-down version of the (already trivial) model 'Test'. <>= procedure :: init_test => model_data_init_test <>= subroutine model_data_init_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 4 integer, parameter :: n_field = 2 integer, parameter :: n_vertex = 2 integer :: i call model%init (var_str ("Test"), & n_real, 0, n_field, n_vertex) i = 0 i = i + 1 call model%init_par (i, var_str ("gy"), 1._default) i = i + 1 call model%init_par (i, var_str ("ms"), 125._default) i = i + 1 call model%init_par (i, var_str ("ff"), 1.5_default) i = i + 1 call model%init_par (i, var_str ("mf"), 1.5_default * 125._default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("SCALAR"), 25) call field%set (spin_type=1) call field%set (mass_data=model%get_par_real_ptr (2)) call field%set (name = [var_str ("s")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("FERMION"), 6) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (4)) call field%set (name = [var_str ("f")], anti = [var_str ("fbar")]) call model%freeze_fields () i = 0 i = i + 1 call model%set_vertex (i, [var_str ("fbar"), var_str ("f"), var_str ("s")]) i = i + 1 call model%set_vertex (i, [var_str ("s"), var_str ("s"), var_str ("s")]) call model%freeze_vertices () end subroutine model_data_init_test @ %def model_data_init_test @ This procedure prepares a subset of QED for testing purposes. <>= procedure :: init_qed_test => model_data_init_qed_test <>= subroutine model_data_init_qed_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 1 integer, parameter :: n_field = 2 integer :: i call model%init (var_str ("QED_test"), & n_real, 0, n_field, 0) i = 0 i = i + 1 call model%init_par (i, var_str ("me"), 0.000510997_default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_LEPTON"), 11) call field%set (spin_type=2, charge_type=-4) call field%set (mass_data=model%get_par_real_ptr (1)) call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PHOTON"), 22) call field%set (spin_type=3) call field%set (name = [var_str ("A")]) call model%freeze_fields () call model%freeze_vertices () end subroutine model_data_init_qed_test @ %def model_data_init_qed_test @ This procedure prepares a subset of the Standard Model for testing purposes. We can thus avoid dependencies on model I/O, which is not defined here. <>= procedure :: init_sm_test => model_data_init_sm_test <>= subroutine model_data_init_sm_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 11 integer, parameter :: n_field = 19 integer, parameter :: n_vtx = 9 integer :: i call model%init (var_str ("SM_test"), & n_real, 0, n_field, n_vtx) i = 0 i = i + 1 call model%init_par (i, var_str ("mZ"), 91.1882_default) i = i + 1 call model%init_par (i, var_str ("mW"), 80.419_default) i = i + 1 call model%init_par (i, var_str ("me"), 0.000510997_default) i = i + 1 call model%init_par (i, var_str ("mmu"), 0.105658389_default) i = i + 1 call model%init_par (i, var_str ("mb"), 4.2_default) i = i + 1 call model%init_par (i, var_str ("mtop"), 173.1_default) i = i + 1 call model%init_par (i, var_str ("wZ"), 2.443_default) i = i + 1 call model%init_par (i, var_str ("wW"), 2.049_default) i = i + 1 call model%init_par (i, var_str ("ee"), 0.3079561542961_default) i = i + 1 call model%init_par (i, var_str ("cw"), 8.819013863636E-01_default) i = i + 1 call model%init_par (i, var_str ("sw"), 4.714339240339E-01_default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("D_QUARK"), 1) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (name = [var_str ("d")], anti = [var_str ("dbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("U_QUARK"), 2) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (name = [var_str ("u")], anti = [var_str ("ubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("S_QUARK"), 3) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (name = [var_str ("s")], anti = [var_str ("sbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("C_QUARK"), 4) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (name = [var_str ("c")], anti = [var_str ("cbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("B_QUARK"), 5) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (mass_data=model%get_par_real_ptr (5)) call field%set (name = [var_str ("b")], anti = [var_str ("bbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("T_QUARK"), 6) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (mass_data=model%get_par_real_ptr (6)) call field%set (name = [var_str ("t")], anti = [var_str ("tbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_LEPTON"), 11) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (3)) call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_NEUTRINO"), 12) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("MU_LEPTON"), 13) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (4)) call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("MU_NEUTRINO"), 14) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("GLUON"), 21) call field%set (spin_type=3, color_type=8) call field%set (name = [var_str ("gl")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PHOTON"), 22) call field%set (spin_type=3) call field%set (name = [var_str ("A")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("Z_BOSON"), 23) call field%set (spin_type=3) call field%set (mass_data=model%get_par_real_ptr (1)) call field%set (width_data=model%get_par_real_ptr (7)) call field%set (name = [var_str ("Z")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("W_BOSON"), 24) call field%set (spin_type=3) call field%set (mass_data=model%get_par_real_ptr (2)) call field%set (width_data=model%get_par_real_ptr (8)) call field%set (name = [var_str ("W+")], anti = [var_str ("W-")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HIGGS"), 25) call field%set (spin_type=1) ! call field%set (mass_data=model%get_par_real_ptr (2)) ! call field%set (width_data=model%get_par_real_ptr (8)) call field%set (name = [var_str ("H")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PROTON"), 2212) call field%set (spin_type=2) call field%set (name = [var_str ("p")], anti = [var_str ("pbar")]) ! call field%set (mass_data=model%get_par_real_ptr (12)) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91) call field%set (color_type=1) call field%set (name = [var_str ("hr1")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92) call field%set (color_type=3) call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_OCTET"), 93) call field%set (color_type=8) call field%set (name = [var_str ("hr8")]) call model%freeze_fields () i = 0 i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")]) call model%freeze_vertices () end subroutine model_data_init_sm_test @ %def model_data_init_sm_test @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Model Testbed} The standard way of defining a model uses concrete variables and expressions to interpret the model file. Some of this is not available at the point of use. This is no problem for the \whizard\ program as a whole, but unit tests are kept local to their respective module and don't access all definitions. Instead, we introduce a separate module that provides hooks, one for initializing a model and one for finalizing a model. The main program can assign real routines to the hooks (procedure pointers of abstract type) before unit tests are called. The unit tests can call the abstract routines without knowing about their implementation. <<[[model_testbed.f90]]>>= <> module model_testbed <> use model_data use var_base <> <> <> <> end module model_testbed @ %def model_testbed @ \subsection{Abstract Model Handlers} Both routines take a polymorphic model (data) target, which is not allocated/deallocated inside the subroutine. The model constructor [[prepare_model]] requires the model name as input. It can, optionally, return a link to the variable list of the model. <>= public :: prepare_model public :: cleanup_model <>= procedure (prepare_model_proc), pointer :: prepare_model => null () procedure (cleanup_model_proc), pointer :: cleanup_model => null () <>= abstract interface subroutine prepare_model_proc (model, name, vars) import class(model_data_t), intent(inout), pointer :: model type(string_t), intent(in) :: name class(vars_t), pointer, intent(out), optional :: vars end subroutine prepare_model_proc end interface abstract interface subroutine cleanup_model_proc (model) import class(model_data_t), intent(inout), target :: model end subroutine cleanup_model_proc end interface @ %def prepare_model @ %def cleanup_model @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Helicities} This module defines types and tools for dealing with helicity information. <<[[helicities.f90]]>>= <> module helicities use io_units <> <> <> <> contains <> end module helicities @ %def helicities @ \subsection{Helicity types} Helicities may be defined or undefined, corresponding to a polarized or unpolarized state. Each helicity is actually a pair of helicities, corresponding to an entry in the spin density matrix. Obviously, diagonal entries are distinguished. <>= public :: helicity_t <>= type :: helicity_t private logical :: defined = .false. integer :: h1, h2 contains <> end type helicity_t @ %def helicity_t @ Constructor functions, for convenience: <>= public :: helicity <>= interface helicity module procedure helicity0, helicity1, helicity2 end interface helicity <>= pure function helicity0 () result (hel) type(helicity_t) :: hel end function helicity0 elemental function helicity1 (h) result (hel) type(helicity_t) :: hel integer, intent(in) :: h call hel%init (h) end function helicity1 elemental function helicity2 (h2, h1) result (hel) type(helicity_t) :: hel integer, intent(in) :: h1, h2 call hel%init (h2, h1) end function helicity2 @ %def helicity @ Initializers. Note: conceptually, the argument to initializers should be INTENT(OUT). However, Interp.\ F08/0033 prohibited this. The reason is that, in principle, the call could result in the execution of an impure finalizer for a type extension of [[hel]] (ugh). <>= generic :: init => helicity_init_empty, helicity_init_same, helicity_init_different procedure, private :: helicity_init_empty procedure, private :: helicity_init_same procedure, private :: helicity_init_different <>= elemental subroutine helicity_init_empty (hel) class(helicity_t), intent(inout) :: hel hel%defined = .false. end subroutine helicity_init_empty elemental subroutine helicity_init_same (hel, h) class(helicity_t), intent(inout) :: hel integer, intent(in) :: h hel%defined = .true. hel%h1 = h hel%h2 = h end subroutine helicity_init_same elemental subroutine helicity_init_different (hel, h2, h1) class(helicity_t), intent(inout) :: hel integer, intent(in) :: h1, h2 hel%defined = .true. hel%h2 = h2 hel%h1 = h1 end subroutine helicity_init_different @ %def helicity_init @ Undefine: <>= procedure :: undefine => helicity_undefine <>= elemental subroutine helicity_undefine (hel) class(helicity_t), intent(inout) :: hel hel%defined = .false. end subroutine helicity_undefine @ %def helicity_undefine @ Diagonalize by removing the second entry (use with care!) <>= procedure :: diagonalize => helicity_diagonalize <>= elemental subroutine helicity_diagonalize (hel) class(helicity_t), intent(inout) :: hel hel%h2 = hel%h1 end subroutine helicity_diagonalize @ %def helicity_diagonalize @ Flip helicity indices by sign. <>= procedure :: flip => helicity_flip <>= elemental subroutine helicity_flip (hel) class(helicity_t), intent(inout) :: hel hel%h1 = - hel%h1 hel%h2 = - hel%h2 end subroutine helicity_flip @ %def helicity_flip @ <>= procedure :: get_indices => helicity_get_indices <>= subroutine helicity_get_indices (hel, h1, h2) class(helicity_t), intent(in) :: hel integer, intent(out) :: h1, h2 h1 = hel%h1; h2 = hel%h2 end subroutine helicity_get_indices @ %def helicity_get_indices @ Output (no linebreak). No output if undefined. <>= procedure :: write => helicity_write <>= subroutine helicity_write (hel, unit) class(helicity_t), intent(in) :: hel integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (hel%defined) then write (u, "(A)", advance="no") "h(" write (u, "(I0)", advance="no") hel%h1 if (hel%h1 /= hel%h2) then write (u, "(A)", advance="no") "|" write (u, "(I0)", advance="no") hel%h2 end if write (u, "(A)", advance="no") ")" end if end subroutine helicity_write @ %def helicity_write @ Binary I/O. Write contents only if defined. <>= procedure :: write_raw => helicity_write_raw procedure :: read_raw => helicity_read_raw <>= subroutine helicity_write_raw (hel, u) class(helicity_t), intent(in) :: hel integer, intent(in) :: u write (u) hel%defined if (hel%defined) then write (u) hel%h1, hel%h2 end if end subroutine helicity_write_raw subroutine helicity_read_raw (hel, u, iostat) class(helicity_t), intent(out) :: hel integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) hel%defined if (hel%defined) then read (u, iostat=iostat) hel%h1, hel%h2 end if end subroutine helicity_read_raw @ %def helicity_write_raw helicity_read_raw @ \subsection{Predicates} Check if the helicity is defined: <>= procedure :: is_defined => helicity_is_defined <>= elemental function helicity_is_defined (hel) result (defined) logical :: defined class(helicity_t), intent(in) :: hel defined = hel%defined end function helicity_is_defined @ %def helicity_is_defined @ Return true if the two helicities are equal or the particle is unpolarized: <>= procedure :: is_diagonal => helicity_is_diagonal <>= elemental function helicity_is_diagonal (hel) result (diagonal) logical :: diagonal class(helicity_t), intent(in) :: hel if (hel%defined) then diagonal = hel%h1 == hel%h2 else diagonal = .true. end if end function helicity_is_diagonal @ %def helicity_is_diagonal @ \subsection{Accessing contents} This returns a two-element array and thus cannot be elemental. The result is unpredictable if the helicity is undefined. <>= procedure :: to_pair => helicity_to_pair <>= pure function helicity_to_pair (hel) result (h) integer, dimension(2) :: h class(helicity_t), intent(in) :: hel h(1) = hel%h2 h(2) = hel%h1 end function helicity_to_pair @ %def helicity_to_pair @ \subsection{Comparisons} When comparing helicities, if either one is undefined, they are considered to match. In other words, an unpolarized particle matches any polarization. In the [[dmatch]] variant, it matches only diagonal helicity. <>= generic :: operator(.match.) => helicity_match generic :: operator(.dmatch.) => helicity_match_diagonal generic :: operator(==) => helicity_eq generic :: operator(/=) => helicity_neq procedure, private :: helicity_match procedure, private :: helicity_match_diagonal procedure, private :: helicity_eq procedure, private :: helicity_neq @ %def .match. .dmatch. == /= <>= elemental function helicity_match (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else eq = .true. end if end function helicity_match elemental function helicity_match_diagonal (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else if (hel1%defined) then eq = hel1%h1 == hel1%h2 else if (hel2%defined) then eq = hel2%h1 == hel2%h2 else eq = .true. end if end function helicity_match_diagonal @ %def helicity_match helicity_match_diagonal <>= elemental function helicity_eq (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else if (.not. hel1%defined .and. .not. hel2%defined) then eq = .true. else eq = .false. end if end function helicity_eq @ %def helicity_eq <>= elemental function helicity_neq (hel1, hel2) result (neq) logical :: neq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then neq = (hel1%h1 /= hel2%h1) .or. (hel1%h2 /= hel2%h2) else if (.not. hel1%defined .and. .not. hel2%defined) then neq = .false. else neq = .true. end if end function helicity_neq @ %def helicity_neq @ \subsection{Tools} Merge two helicity objects by taking the first entry from the first and the second entry from the second argument. Makes sense only if the input helicities were defined and diagonal. The handling of ghost flags is not well-defined; one should verify beforehand that they match. <>= generic :: operator(.merge.) => merge_helicities procedure, private :: merge_helicities @ %def .merge. <>= elemental function merge_helicities (hel1, hel2) result (hel) type(helicity_t) :: hel class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then call hel%init (hel2%h1, hel1%h1) else if (hel1%defined) then call hel%init (hel1%h2, hel1%h1) else if (hel2%defined) then call hel%init (hel2%h2, hel2%h1) end if end function merge_helicities @ %def merge_helicities @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Colors} This module defines a type and tools for dealing with color information. Each particle can have zero or more (in practice, usually not more than two) color indices. Color indices are positive; flow direction can be determined from the particle nature. While parton shower matrix elements are diagonal in color, some special applications (e.g., subtractions for NLO matrix elements) require non-diagonal color matrices. <<[[colors.f90]]>>= <> module colors <> <> use io_units use diagnostics <> <> <> <> contains <> end module colors @ %def colors @ \subsection{The color type} A particle may have an arbitrary number of color indices (in practice, from zero to two, but more are possible). This object acts as a container. (The current implementation has a fixed array of length two.) The fact that color comes as an array prohibits elemental procedures in some places. (May add interfaces and multi versions where necessary.) The color may be undefined. NOTE: Due to a compiler bug in nagfor 5.2, we do not use allocatable but fixed-size arrays with dimension 2. Only nonzero entries count. This may be more efficient anyway, but gives up some flexibility. However, the squaring algorithm currently works only for singlets, (anti)triplets and octets anyway, so two components are enough. This type has to be generalized (abstract type and specific implementations) when trying to pursue generalized color flows or Monte Carlo over continuous color. <>= public :: color_t <>= type :: color_t private logical :: defined = .false. integer, dimension(2) :: c1 = 0, c2 = 0 logical :: ghost = .false. contains <> end type color_t @ %def color_t @ Initializers: <>= generic :: init => & color_init_trivial, color_init_trivial_ghost, & color_init_array, color_init_array_ghost, & color_init_arrays, color_init_arrays_ghost procedure, private :: color_init_trivial procedure, private :: color_init_trivial_ghost procedure, private :: color_init_array procedure, private :: color_init_array_ghost procedure, private :: color_init_arrays procedure, private :: color_init_arrays_ghost @ Undefined color: array remains unallocated <>= pure subroutine color_init_trivial (col) class(color_t), intent(inout) :: col col%defined = .true. col%c1 = 0 col%c2 = 0 col%ghost = .false. end subroutine color_init_trivial pure subroutine color_init_trivial_ghost (col, ghost) class(color_t), intent(inout) :: col logical, intent(in) :: ghost col%defined = .true. col%c1 = 0 col%c2 = 0 col%ghost = ghost end subroutine color_init_trivial_ghost @ This defines color from an arbitrary length color array, suitable for any representation. We may have two color arrays (non-diagonal matrix elements). This cannot be elemental. The third version assigns an array of colors, using a two-dimensional array as input. <>= pure subroutine color_init_array (col, c1) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 col%defined = .true. col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = col%c1 col%ghost = .false. end subroutine color_init_array pure subroutine color_init_array_ghost (col, c1, ghost) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, intent(in) :: ghost call color_init_array (col, c1) col%ghost = ghost end subroutine color_init_array_ghost pure subroutine color_init_arrays (col, c1, c2) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1, c2 col%defined = .true. if (size (c1) == size (c2)) then col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = pack (c2, c2 /= 0, [0,0]) else if (size (c1) /= 0) then col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = col%c1 else if (size (c2) /= 0) then col%c1 = pack (c2, c2 /= 0, [0,0]) col%c2 = col%c1 end if col%ghost = .false. end subroutine color_init_arrays pure subroutine color_init_arrays_ghost (col, c1, c2, ghost) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1, c2 logical, intent(in) :: ghost call color_init_arrays (col, c1, c2) col%ghost = ghost end subroutine color_init_arrays_ghost @ %def color_init @ This version is restricted to singlets, triplets, antitriplets, and octets: The input contains the color and anticolor index, each of the may be zero. <>= procedure :: init_col_acl => color_init_col_acl <>= elemental subroutine color_init_col_acl (col, col_in, acl_in) class(color_t), intent(inout) :: col integer, intent(in) :: col_in, acl_in integer, dimension(0) :: null_array select case (col_in) case (0) select case (acl_in) case (0) call color_init_array (col, null_array) case default call color_init_array (col, [-acl_in]) end select case default select case (acl_in) case (0) call color_init_array (col, [col_in]) case default call color_init_array (col, [col_in, -acl_in]) end select end select end subroutine color_init_col_acl @ %def color_init_col_acl @ This version is used for the external interface. We convert a fixed-size array of colors (for each particle) to the internal form by packing only the nonzero entries. Some of these procedures produce an arry, so they can't be all type-bound. We implement them as ordinary procedures. <>= public :: color_init_from_array <>= interface color_init_from_array module procedure color_init_from_array1 module procedure color_init_from_array1g module procedure color_init_from_array2 module procedure color_init_from_array2g end interface color_init_from_array @ %def color_init_from_array <>= pure subroutine color_init_from_array1 (col, c1) type(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, dimension(size(c1)) :: mask mask = c1 /= 0 col%defined = .true. col%c1 = pack (c1, mask, col%c1) col%c2 = col%c1 col%ghost = .false. end subroutine color_init_from_array1 pure subroutine color_init_from_array1g (col, c1, ghost) type(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, intent(in) :: ghost call color_init_from_array1 (col, c1) col%ghost = ghost end subroutine color_init_from_array1g pure subroutine color_init_from_array2 (col, c1) integer, dimension(:,:), intent(in) :: c1 type(color_t), dimension(:), intent(inout) :: col integer :: i do i = 1, size (c1,2) call color_init_from_array1 (col(i), c1(:,i)) end do end subroutine color_init_from_array2 pure subroutine color_init_from_array2g (col, c1, ghost) integer, dimension(:,:), intent(in) :: c1 type(color_t), dimension(:), intent(out) :: col logical, intent(in), dimension(:) :: ghost call color_init_from_array2 (col, c1) col%ghost = ghost end subroutine color_init_from_array2g @ %def color_init_from_array @ Set the ghost property <>= procedure :: set_ghost => color_set_ghost <>= elemental subroutine color_set_ghost (col, ghost) class(color_t), intent(inout) :: col logical, intent(in) :: ghost col%ghost = ghost end subroutine color_set_ghost @ %def color_set_ghost @ Undefine the color state: <>= procedure :: undefine => color_undefine <>= elemental subroutine color_undefine (col, undefine_ghost) class(color_t), intent(inout) :: col logical, intent(in), optional :: undefine_ghost col%defined = .false. if (present (undefine_ghost)) then if (undefine_ghost) col%ghost = .false. else col%ghost = .false. end if end subroutine color_undefine @ %def color_undefine @ Output. As dense as possible, no linebreak. If color is undefined, no output. The separate version for a color array suggest two distinct interfaces. <>= public :: color_write <>= interface color_write module procedure color_write_single module procedure color_write_array end interface color_write <>= procedure :: write => color_write_single <>= subroutine color_write_single (col, unit) class(color_t), intent(in) :: col integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (col%ghost) then write (u, "(A)", advance="no") "c*" else if (col%defined) then write (u, "(A)", advance="no") "c(" if (col%c1(1) /= 0) write (u, "(I0)", advance="no") col%c1(1) if (any (col%c1 /= 0)) write (u, "(1x)", advance="no") if (col%c1(2) /= 0) write (u, "(I0)", advance="no") col%c1(2) if (.not. col%is_diagonal ()) then write (u, "(A)", advance="no") "|" if (col%c2(1) /= 0) write (u, "(I0)", advance="no") col%c2(1) if (any (col%c2 /= 0)) write (u, "(1x)", advance="no") if (col%c2(2) /= 0) write (u, "(I0)", advance="no") col%c2(2) end if write (u, "(A)", advance="no") ")" end if end subroutine color_write_single subroutine color_write_array (col, unit) type(color_t), dimension(:), intent(in) :: col integer, intent(in), optional :: unit integer :: u integer :: i u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" do i = 1, size (col) if (i > 1) write (u, "(1x)", advance="no") call color_write_single (col(i), u) end do write (u, "(A)", advance="no") "]" end subroutine color_write_array @ %def color_write @ Binary I/O. For allocatable colors, this would have to be modified. <>= procedure :: write_raw => color_write_raw procedure :: read_raw => color_read_raw <>= subroutine color_write_raw (col, u) class(color_t), intent(in) :: col integer, intent(in) :: u logical :: defined defined = col%is_defined () .or. col%is_ghost () write (u) defined if (defined) then write (u) col%c1, col%c2 write (u) col%ghost end if end subroutine color_write_raw subroutine color_read_raw (col, u, iostat) class(color_t), intent(inout) :: col integer, intent(in) :: u integer, intent(out), optional :: iostat logical :: defined read (u, iostat=iostat) col%defined if (col%defined) then read (u, iostat=iostat) col%c1, col%c2 read (u, iostat=iostat) col%ghost end if end subroutine color_read_raw @ %def color_write_raw color_read_raw @ \subsection{Predicates} Return the definition status. A color state may be defined but trivial. <>= procedure :: is_defined => color_is_defined procedure :: is_nonzero => color_is_nonzero <>= elemental function color_is_defined (col) result (defined) logical :: defined class(color_t), intent(in) :: col defined = col%defined end function color_is_defined elemental function color_is_nonzero (col) result (flag) logical :: flag class(color_t), intent(in) :: col flag = col%defined & .and. .not. col%ghost & .and. any (col%c1 /= 0 .or. col%c2 /= 0) end function color_is_nonzero @ %def color_is_defined @ %def color_is_nonzero @ Diagonal color objects have only one array allocated: <>= procedure :: is_diagonal => color_is_diagonal <>= elemental function color_is_diagonal (col) result (diagonal) logical :: diagonal class(color_t), intent(in) :: col if (col%defined) then diagonal = all (col%c1 == col%c2) else diagonal = .true. end if end function color_is_diagonal @ %def color_is_diagonal @ Return the ghost flag <>= procedure :: is_ghost => color_is_ghost <>= elemental function color_is_ghost (col) result (ghost) logical :: ghost class(color_t), intent(in) :: col ghost = col%ghost end function color_is_ghost @ %def color_is_ghost @ The ghost parity: true if the color-ghost flag is set. Again, no TBP since this is an array. <>= pure function color_ghost_parity (col) result (parity) type(color_t), dimension(:), intent(in) :: col logical :: parity parity = mod (count (col%ghost), 2) == 1 end function color_ghost_parity @ %def color_ghost_parity @ Determine the color representation, given a color object. We allow only singlet ($1$), (anti)triplet ($\pm 3$), and octet states ($8$). A color ghost must not have color assigned, but the color type is $8$. For non-diagonal color, representations must match. If the color type is undefined, return $0$. If it is invalid or unsupported, return $-1$. Assumption: nonzero entries precede nonzero ones. <>= procedure :: get_type => color_get_type <>= elemental function color_get_type (col) result (ctype) class(color_t), intent(in) :: col integer :: ctype if (col%defined) then ctype = -1 if (col%ghost) then if (all (col%c1 == 0 .and. col%c2 == 0)) then ctype = 8 end if else if (all ((col%c1 == 0 .and. col%c2 == 0) & & .or. (col%c1 > 0 .and. col%c2 > 0) & & .or. (col%c1 < 0 .and. col%c2 < 0))) then if (all (col%c1 == 0)) then ctype = 1 else if ((col%c1(1) > 0 .and. col%c1(2) == 0)) then ctype = 3 else if ((col%c1(1) < 0 .and. col%c1(2) == 0)) then ctype = -3 else if ((col%c1(1) > 0 .and. col%c1(2) < 0) & .or.(col%c1(1) < 0 .and. col%c1(2) > 0)) then ctype = 8 end if end if end if else ctype = 0 end if end function color_get_type @ %def color_get_type @ \subsection{Accessing contents} Return the number of color indices. We assume that it is identical for both arrays. <>= procedure, private :: get_number_of_indices => color_get_number_of_indices <>= elemental function color_get_number_of_indices (col) result (n) integer :: n class(color_t), intent(in) :: col if (col%defined .and. .not. col%ghost) then n = count (col%c1 /= 0) else n = 0 end if end function color_get_number_of_indices @ %def color_get_number_of_indices @ Return the (first) color/anticolor entry (assuming that color is diagonal). The result is a positive color index. <>= procedure :: get_col => color_get_col procedure :: get_acl => color_get_acl <>= elemental function color_get_col (col) result (c) integer :: c class(color_t), intent(in) :: col integer :: i if (col%defined .and. .not. col%ghost) then do i = 1, size (col%c1) if (col%c1(i) > 0) then c = col%c1(i) return end if end do end if c = 0 end function color_get_col elemental function color_get_acl (col) result (c) integer :: c class(color_t), intent(in) :: col integer :: i if (col%defined .and. .not. col%ghost) then do i = 1, size (col%c1) if (col%c1(i) < 0) then c = - col%c1(i) return end if end do end if c = 0 end function color_get_acl @ %def color_get_col color_get_acl @ Return the color index with highest absolute value <>= public :: color_get_max_value <>= interface color_get_max_value module procedure color_get_max_value0 module procedure color_get_max_value1 module procedure color_get_max_value2 end interface color_get_max_value <>= elemental function color_get_max_value0 (col) result (cmax) integer :: cmax type(color_t), intent(in) :: col if (col%defined .and. .not. col%ghost) then cmax = maxval (abs (col%c1)) else cmax = 0 end if end function color_get_max_value0 pure function color_get_max_value1 (col) result (cmax) integer :: cmax type(color_t), dimension(:), intent(in) :: col cmax = maxval (color_get_max_value0 (col)) end function color_get_max_value1 pure function color_get_max_value2 (col) result (cmax) integer :: cmax type(color_t), dimension(:,:), intent(in) :: col integer, dimension(size(col, 2)) :: cm integer :: i forall (i = 1:size(col, 2)) cm(i) = color_get_max_value1 (col(:,i)) end forall cmax = maxval (cm) end function color_get_max_value2 @ %def color_get_max_value @ \subsection{Comparisons} Similar to helicities, colors match if they are equal, or if either one is undefined. <>= generic :: operator(.match.) => color_match generic :: operator(==) => color_eq generic :: operator(/=) => color_neq procedure, private :: color_match procedure, private :: color_eq procedure, private :: color_neq @ %def .match. == /= <>= elemental function color_match (col1, col2) result (eq) logical :: eq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then eq = .true. else if (.not. col1%ghost .and. .not. col2%ghost) then eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2) else eq = .false. end if else eq = .true. end if end function color_match elemental function color_eq (col1, col2) result (eq) logical :: eq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then eq = .true. else if (.not. col1%ghost .and. .not. col2%ghost) then eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2) else eq = .false. end if else if (.not. col1%defined & .and. .not. col2%defined) then eq = col1%ghost .eqv. col2%ghost else eq = .false. end if end function color_eq @ %def color_eq <>= elemental function color_neq (col1, col2) result (neq) logical :: neq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then neq = .false. else if (.not. col1%ghost .and. .not. col2%ghost) then neq = any (col1%c1 /= col2%c1) .or. any (col1%c2 /= col2%c2) else neq = .true. end if else if (.not. col1%defined & .and. .not. col2%defined) then neq = col1%ghost .neqv. col2%ghost else neq = .true. end if end function color_neq @ %def color_neq @ \subsection{Tools} Shift color indices by a common offset. <>= procedure :: add_offset => color_add_offset <>= elemental subroutine color_add_offset (col, offset) class(color_t), intent(inout) :: col integer, intent(in) :: offset if (col%defined .and. .not. col%ghost) then where (col%c1 /= 0) col%c1 = col%c1 + sign (offset, col%c1) where (col%c2 /= 0) col%c2 = col%c2 + sign (offset, col%c2) end if end subroutine color_add_offset @ %def color_add_offset @ Reassign color indices for an array of colored particle in canonical order. The allocated size of the color map is such that two colors per particle can be accomodated. The algorithm works directly on the contents of the color objects, it <>= public :: color_canonicalize <>= subroutine color_canonicalize (col) type(color_t), dimension(:), intent(inout) :: col integer, dimension(2*size(col)) :: map integer :: n_col, i, j, k n_col = 0 do i = 1, size (col) if (col(i)%defined .and. .not. col(i)%ghost) then do j = 1, size (col(i)%c1) if (col(i)%c1(j) /= 0) then k = find (abs (col(i)%c1(j)), map(:n_col)) if (k == 0) then n_col = n_col + 1 map(n_col) = abs (col(i)%c1(j)) k = n_col end if col(i)%c1(j) = sign (k, col(i)%c1(j)) end if if (col(i)%c2(j) /= 0) then k = find (abs (col(i)%c2(j)), map(:n_col)) if (k == 0) then n_col = n_col + 1 map(n_col) = abs (col(i)%c2(j)) k = n_col end if col(i)%c2(j) = sign (k, col(i)%c2(j)) end if end do end if end do contains function find (c, array) result (k) integer :: k integer, intent(in) :: c integer, dimension(:), intent(in) :: array integer :: i k = 0 do i = 1, size (array) if (c == array (i)) then k = i return end if end do end function find end subroutine color_canonicalize @ %def color_canonicalize @ Return an array of different color indices from an array of colors. The last argument is a pseudo-color array, where the color entries correspond to the position of the corresponding index entry in the index array. The colors are assumed to be diagonal. The algorithm works directly on the contents of the color objects. <>= subroutine extract_color_line_indices (col, c_index, col_pos) type(color_t), dimension(:), intent(in) :: col integer, dimension(:), intent(out), allocatable :: c_index type(color_t), dimension(size(col)), intent(out) :: col_pos integer, dimension(:), allocatable :: c_tmp integer :: i, j, k, n, c allocate (c_tmp (sum (col%get_number_of_indices ())), source=0) n = 0 SCAN1: do i = 1, size (col) if (col(i)%defined .and. .not. col(i)%ghost) then SCAN2: do j = 1, 2 c = abs (col(i)%c1(j)) if (c /= 0) then do k = 1, n if (c_tmp(k) == c) then col_pos(i)%c1(j) = k cycle SCAN2 end if end do n = n + 1 c_tmp(n) = c col_pos(i)%c1(j) = n end if end do SCAN2 end if end do SCAN1 allocate (c_index (n)) c_index = c_tmp(1:n) end subroutine extract_color_line_indices @ %def extract_color_line_indices @ Given a color array, pairwise contract the color lines in all possible ways and return the resulting array of arrays. The input color array must be diagonal, and each color should occur exactly twice, once as color and once as anticolor. Gluon entries with equal color and anticolor are explicitly excluded. This algorithm is generic, but for long arrays it is neither efficient, nor does it avoid duplicates. It is intended for small arrays, in particular for the state matrix of a structure-function pair. The algorithm works directly on the contents of the color objects, it thus depends on the implementation. <>= public :: color_array_make_contractions <>= subroutine color_array_make_contractions (col_in, col_out) type(color_t), dimension(:), intent(in) :: col_in type(color_t), dimension(:,:), intent(out), allocatable :: col_out type :: entry_t integer, dimension(:), allocatable :: map type(color_t), dimension(:), allocatable :: col type(entry_t), pointer :: next => null () logical :: nlo_event = .false. end type entry_t type :: list_t integer :: n = 0 type(entry_t), pointer :: first => null () type(entry_t), pointer :: last => null () end type list_t type(list_t) :: list type(entry_t), pointer :: entry integer, dimension(:), allocatable :: c_index type(color_t), dimension(size(col_in)) :: col_pos integer :: n_prt, n_c_index integer, dimension(:), allocatable :: map integer :: i, j, c n_prt = size (col_in) call extract_color_line_indices (col_in, c_index, col_pos) n_c_index = size (c_index) allocate (map (n_c_index)) map = 0 call list_append_if_valid (list, map) entry => list%first do while (associated (entry)) do i = 1, n_c_index if (entry%map(i) == 0) then c = c_index(i) do j = i + 1, n_c_index if (entry%map(j) == 0) then map = entry%map map(i) = c map(j) = c call list_append_if_valid (list, map) end if end do end if end do entry => entry%next end do call list_to_array (list, col_out) contains subroutine list_append_if_valid (list, map) type(list_t), intent(inout) :: list integer, dimension(:), intent(in) :: map type(entry_t), pointer :: entry integer :: i, j, c, p entry => list%first do while (associated (entry)) if (all (map == entry%map)) return entry => entry%next end do allocate (entry) allocate (entry%map (n_c_index)) entry%map = map allocate (entry%col (n_prt)) do i = 1, n_prt do j = 1, 2 c = col_in(i)%c1(j) if (c /= 0) then p = col_pos(i)%c1(j) entry%col(i)%defined = .true. if (map(p) /= 0) then entry%col(i)%c1(j) = sign (map(p), c) else entry%col(i)%c1(j) = c endif entry%col(i)%c2(j) = entry%col(i)%c1(j) end if end do if (any (entry%col(i)%c1 /= 0) .and. & entry%col(i)%c1(1) == - entry%col(i)%c1(2)) return end do if (associated (list%last)) then list%last%next => entry else list%first => entry end if list%last => entry list%n = list%n + 1 end subroutine list_append_if_valid subroutine list_to_array (list, col) type(list_t), intent(inout) :: list type(color_t), dimension(:,:), intent(out), allocatable :: col type(entry_t), pointer :: entry integer :: i allocate (col (n_prt, list%n - 1)) do i = 0, list%n - 1 entry => list%first list%first => list%first%next if (i /= 0) col(:,i) = entry%col deallocate (entry) end do list%last => null () end subroutine list_to_array end subroutine color_array_make_contractions @ %def color_array_make_contractions @ Invert the color index, switching from particle to antiparticle. For gluons, we have to swap the order of color entries. <>= procedure :: invert => color_invert <>= elemental subroutine color_invert (col) class(color_t), intent(inout) :: col if (col%defined .and. .not. col%ghost) then col%c1 = - col%c1 col%c2 = - col%c2 if (col%c1(1) < 0 .and. col%c1(2) > 0) then col%c1 = col%c1(2:1:-1) col%c2 = col%c2(2:1:-1) end if end if end subroutine color_invert @ %def color_invert @ Make a color map for two matching color arrays. The result is an array of integer pairs. <>= public :: make_color_map <>= interface make_color_map module procedure color_make_color_map end interface make_color_map <>= subroutine color_make_color_map (map, col1, col2) integer, dimension(:,:), intent(out), allocatable :: map type(color_t), dimension(:), intent(in) :: col1, col2 integer, dimension(:,:), allocatable :: map1 integer :: i, j, k allocate (map1 (2, 2 * sum (col1%get_number_of_indices ()))) k = 0 do i = 1, size (col1) if (col1(i)%defined .and. .not. col1(i)%ghost) then do j = 1, size (col1(i)%c1) if (col1(i)%c1(j) /= 0 & .and. all (map1(1,:k) /= abs (col1(i)%c1(j)))) then k = k + 1 map1(1,k) = abs (col1(i)%c1(j)) map1(2,k) = abs (col2(i)%c1(j)) end if if (col1(i)%c2(j) /= 0 & .and. all (map1(1,:k) /= abs (col1(i)%c2(j)))) then k = k + 1 map1(1,k) = abs (col1(i)%c2(j)) map1(2,k) = abs (col2(i)%c2(j)) end if end do end if end do allocate (map (2, k)) map(:,:) = map1(:,:k) end subroutine color_make_color_map @ %def make_color_map @ Translate colors which have a match in the translation table (an array of integer pairs). Color that do not match an entry are simply transferred; this is done by first transferring all components, then modifiying entries where appropriate. <>= public :: color_translate <>= interface color_translate module procedure color_translate0 module procedure color_translate0_offset module procedure color_translate1 end interface color_translate <>= subroutine color_translate0 (col, map) type(color_t), intent(inout) :: col integer, dimension(:,:), intent(in) :: map type(color_t) :: col_tmp integer :: i if (col%defined .and. .not. col%ghost) then col_tmp = col do i = 1, size (map,2) where (abs (col%c1) == map(1,i)) col_tmp%c1 = sign (map(2,i), col%c1) end where where (abs (col%c2) == map(1,i)) col_tmp%c2 = sign (map(2,i), col%c2) end where end do col = col_tmp end if end subroutine color_translate0 subroutine color_translate0_offset (col, map, offset) type(color_t), intent(inout) :: col integer, dimension(:,:), intent(in) :: map integer, intent(in) :: offset logical, dimension(size(col%c1)) :: mask1, mask2 type(color_t) :: col_tmp integer :: i if (col%defined .and. .not. col%ghost) then col_tmp = col mask1 = col%c1 /= 0 mask2 = col%c2 /= 0 do i = 1, size (map,2) where (abs (col%c1) == map(1,i)) col_tmp%c1 = sign (map(2,i), col%c1) mask1 = .false. end where where (abs (col%c2) == map(1,i)) col_tmp%c2 = sign (map(2,i), col%c2) mask2 = .false. end where end do col = col_tmp where (mask1) col%c1 = sign (abs (col%c1) + offset, col%c1) where (mask2) col%c2 = sign (abs (col%c2) + offset, col%c2) end if end subroutine color_translate0_offset subroutine color_translate1 (col, map, offset) type(color_t), dimension(:), intent(inout) :: col integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset integer :: i if (present (offset)) then do i = 1, size (col) call color_translate0_offset (col(i), map, offset) end do else do i = 1, size (col) call color_translate0 (col(i), map) end do end if end subroutine color_translate1 @ %def color_translate @ Merge two color objects by taking the first entry from the first and the first entry from the second argument. Makes sense only if the input colors are defined (and diagonal). If either one is undefined, transfer the defined one. <>= generic :: operator(.merge.) => merge_colors procedure, private :: merge_colors @ %def .merge. <>= elemental function merge_colors (col1, col2) result (col) type(color_t) :: col class(color_t), intent(in) :: col1, col2 if (color_is_defined (col1) .and. color_is_defined (col2)) then if (color_is_ghost (col1) .and. color_is_ghost (col2)) then call color_init_trivial_ghost (col, .true.) else call color_init_arrays (col, col1%c1, col2%c1) end if else if (color_is_defined (col1)) then call color_init_array (col, col1%c1) else if (color_is_defined (col2)) then call color_init_array (col, col2%c1) end if end function merge_colors @ %def merge_colors @ Merge up to two (diagonal!) color objects. The result inherits the unmatched color lines of the input colors. If one of the input colors is undefined, the output is undefined as well. It must be in a supported color representation. A color-ghost object should not actually occur in real-particle events, but for completeness we define its behavior. For simplicity, it is identified as a color-octet with zero color/anticolor. It can only couple to a triplet or antitriplet. A fusion of triplet with matching antitriplet will yield a singlet, not a ghost, however. If the fusion fails, the result is undefined. NOTE: The [[select type]] casting is required by gfortran 4.8. It may not be required by the standard. <>= generic :: operator (.fuse.) => color_fusion procedure, private :: color_fusion <>= function color_fusion (col1, col2) result (col) class(color_t), intent(in) :: col1, col2 type(color_t) :: col integer, dimension(2) :: ctype if (col1%is_defined () .and. col2%is_defined ()) then if (col1%is_diagonal () .and. col2%is_diagonal ()) then select type (col1) type is (color_t) select type (col2) type is (color_t) ctype = [col1%get_type (), col2%get_type ()] select case (ctype(1)) case (1) select case (ctype(2)) case (1,3,-3,8) col = col2 end select case (3) select case (ctype(2)) case (1) col = col1 case (-3) call t_a (col1%get_col (), col2%get_acl ()) case (8) call t_o (col1%get_col (), col2%get_acl (), & & col2%get_col ()) end select case (-3) select case (ctype(2)) case (1) col = col1 case (3) call t_a (col2%get_col (), col1%get_acl ()) case (8) call a_o (col1%get_acl (), col2%get_col (), & & col2%get_acl ()) end select case (8) select case (ctype(2)) case (1) col = col1 case (3) call t_o (col2%get_col (), col1%get_acl (), & & col1%get_col ()) case (-3) call a_o (col2%get_acl (), col1%get_col (), & & col1%get_acl ()) case (8) call o_o (col1%get_col (), col1%get_acl (), & & col2%get_col (), col2%get_acl ()) end select end select end select end select end if end if contains subroutine t_a (c1, c2) integer, intent(in) :: c1, c2 if (c1 == c2) then call col%init_col_acl (0, 0) else call col%init_col_acl (c1, c2) end if end subroutine t_a subroutine t_o (c1, c2, c3) integer, intent(in) :: c1, c2, c3 if (c1 == c2) then call col%init_col_acl (c3, 0) else if (c2 == 0 .and. c3 == 0) then call col%init_col_acl (c1, 0) end if end subroutine t_o subroutine a_o (c1, c2, c3) integer, intent(in) :: c1, c2, c3 if (c1 == c2) then call col%init_col_acl (0, c3) else if (c2 == 0 .and. c3 == 0) then call col%init_col_acl (0, c1) end if end subroutine a_o subroutine o_o (c1, c2, c3, c4) integer, intent(in) :: c1, c2, c3, c4 if (all ([c1,c2,c3,c4] /= 0)) then if (c2 == c3 .and. c4 == c1) then call col%init_col_acl (0, 0) else if (c2 == c3) then call col%init_col_acl (c1, c4) else if (c4 == c1) then call col%init_col_acl (c3, c2) end if end if end subroutine o_o end function color_fusion @ %def color_fusion @ Compute the color factor, given two interfering color arrays. <>= public :: compute_color_factor <>= function compute_color_factor (col1, col2, nc) result (factor) real(default) :: factor type(color_t), dimension(:), intent(in) :: col1, col2 integer, intent(in), optional :: nc type(color_t), dimension(size(col1)) :: col integer :: ncol, nloops, nghost ncol = 3; if (present (nc)) ncol = nc col = col1 .merge. col2 nloops = count_color_loops (col) nghost = count (col%is_ghost ()) factor = real (ncol, default) ** (nloops - nghost) if (color_ghost_parity (col)) factor = - factor end function compute_color_factor @ %def compute_color_factor @ We have a pair of color index arrays which corresponds to a squared matrix element. We want to determine the number of color loops in this square matrix element. So we first copy the colors (stored in a single color array with a pair of color lists in each entry) to a temporary where the color indices are shifted by some offset. We then recursively follow each loop, starting at the first color that has the offset, resetting the first color index to the loop index and each further index to zero as we go. We check that (a) each color index occurs twice within the left (right) color array, (b) the loops are closed, so we always come back to a line which has the loop index. In order for the algorithm to work we have to conjugate the colors of initial state particles (one for decays, two for scatterings) into their corresponding anticolors of outgoing particles. <>= public :: count_color_loops <>= function count_color_loops (col) result (count) integer :: count type(color_t), dimension(:), intent(in) :: col type(color_t), dimension(size(col)) :: cc integer :: i, n, offset cc = col n = size (cc) offset = n call color_add_offset (cc, offset) count = 0 SCAN_LOOPS: do do i = 1, n if (color_is_nonzero (cc(i))) then if (any (cc(i)%c1 > offset)) then count = count + 1 call follow_line1 (pick_new_line (cc(i)%c1, count, 1)) cycle SCAN_LOOPS end if end if end do exit SCAN_LOOPS end do SCAN_LOOPS contains function pick_new_line (c, reset_val, sgn) result (line) integer :: line integer, dimension(:), intent(inout) :: c integer, intent(in) :: reset_val integer, intent(in) :: sgn integer :: i if (any (c == count)) then line = count else do i = 1, size (c) if (sign (1, c(i)) == sgn .and. abs (c(i)) > offset) then line = c(i) c(i) = reset_val return end if end do call color_mismatch end if end function pick_new_line subroutine reset_line (c, line) integer, dimension(:), intent(inout) :: c integer, intent(in) :: line integer :: i do i = 1, size (c) if (c(i) == line) then c(i) = 0 return end if end do end subroutine reset_line recursive subroutine follow_line1 (line) integer, intent(in) :: line integer :: i if (line == count) return do i = 1, n if (any (cc(i)%c1 == -line)) then call reset_line (cc(i)%c1, -line) call follow_line2 (pick_new_line (cc(i)%c2, 0, sign (1, -line))) return end if end do call color_mismatch () end subroutine follow_line1 recursive subroutine follow_line2 (line) integer, intent(in) :: line integer :: i do i = 1, n if (any (cc(i)%c2 == -line)) then call reset_line (cc(i)%c2, -line) call follow_line1 (pick_new_line (cc(i)%c1, 0, sign (1, -line))) return end if end do call color_mismatch () end subroutine follow_line2 subroutine color_mismatch () call color_write (col) print * call msg_fatal ("Color flow mismatch: Non-closed color lines appear during ", & [var_str ("the evaluation of color correlations. This can happen if there "), & var_str ("are different color structures in the initial or final state of "), & var_str ("the process definition. If so, please use separate processes for "), & var_str ("the different initial / final states. In a future WHIZARD version "), & var_str ("this will be fixed.")]) end subroutine color_mismatch end function count_color_loops @ %def count_color_loops @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[colors_ut.f90]]>>= <> module colors_ut use unit_tests use colors_uti <> <> contains <> end module colors_ut @ %def colors_ut @ <<[[colors_uti.f90]]>>= <> module colors_uti use colors <> <> contains <> end module colors_uti @ %def colors_ut @ API: driver for the unit tests below. <>= public :: color_test <>= subroutine color_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine color_test @ %def color_test @ This is a color counting test. <>= call test (color_1, "color_1", & "check color counting", & u, results) <>= public :: color_1 <>= subroutine color_1 (u) integer, intent(in) :: u type(color_t), dimension(4) :: col1, col2, col type(color_t), dimension(:), allocatable :: col3 type(color_t), dimension(:,:), allocatable :: col_array integer :: count, i call col1%init_col_acl ([1, 0, 2, 3], [0, 1, 3, 2]) col2 = col1 call color_write (col1, u) write (u, "(A)") call color_write (col2, u) write (u, "(A)") col = col1 .merge. col2 call color_write (col, u) write (u, "(A)") count = count_color_loops (col) write (u, "(A,I1)") "Number of color loops (3): ", count call col2%init_col_acl ([1, 0, 2, 3], [0, 2, 3, 1]) call color_write (col1, u) write (u, "(A)") call color_write (col2, u) write (u, "(A)") col = col1 .merge. col2 call color_write (col, u) write (u, "(A)") count = count_color_loops (col) write (u, "(A,I1)") "Number of color loops (2): ", count write (u, "(A)") allocate (col3 (4)) call color_init_from_array (col3, & reshape ([1, 0, 0, -1, 2, -3, 3, -2], & [2, 4])) call color_write (col3, u) write (u, "(A)") call color_array_make_contractions (col3, col_array) write (u, "(A)") "Contractions:" do i = 1, size (col_array, 2) call color_write (col_array(:,i), u) write (u, "(A)") end do deallocate (col3) write (u, "(A)") allocate (col3 (6)) call color_init_from_array (col3, & reshape ([1, -2, 3, 0, 0, -1, 2, -4, -3, 0, 4, 0], & [2, 6])) call color_write (col3, u) write (u, "(A)") call color_array_make_contractions (col3, col_array) write (u, "(A)") "Contractions:" do i = 1, size (col_array, 2) call color_write (col_array(:,i), u) write (u, "(A)") end do end subroutine color_1 @ %def color_1 @ A color fusion test. <>= call test (color_2, "color_2", & "color fusion", & u, results) <>= public :: color_2 <>= subroutine color_2 (u) integer, intent(in) :: u type(color_t) :: s1, t1, t2, a1, a2, o1, o2, o3, o4, g1 write (u, "(A)") "* Test output: color_2" write (u, "(A)") "* Purpose: test all combinations for color-object fusion" write (u, "(A)") call s1%init_col_acl (0,0) call t1%init_col_acl (1,0) call t2%init_col_acl (2,0) call a1%init_col_acl (0,1) call a2%init_col_acl (0,2) call o1%init_col_acl (1,2) call o2%init_col_acl (1,3) call o3%init_col_acl (2,3) call o4%init_col_acl (2,1) call g1%init (ghost=.true.) call wrt ("s1", s1) call wrt ("t1", t1) call wrt ("t2", t2) call wrt ("a1", a1) call wrt ("a2", a2) call wrt ("o1", o1) call wrt ("o2", o2) call wrt ("o3", o3) call wrt ("o4", o4) call wrt ("g1", g1) write (u, *) call wrt ("s1 * s1", s1 .fuse. s1) write (u, *) call wrt ("s1 * t1", s1 .fuse. t1) call wrt ("s1 * a1", s1 .fuse. a1) call wrt ("s1 * o1", s1 .fuse. o1) write (u, *) call wrt ("t1 * s1", t1 .fuse. s1) call wrt ("a1 * s1", a1 .fuse. s1) call wrt ("o1 * s1", o1 .fuse. s1) write (u, *) call wrt ("t1 * t1", t1 .fuse. t1) write (u, *) call wrt ("t1 * t2", t1 .fuse. t2) call wrt ("t1 * a1", t1 .fuse. a1) call wrt ("t1 * a2", t1 .fuse. a2) call wrt ("t1 * o1", t1 .fuse. o1) call wrt ("t2 * o1", t2 .fuse. o1) write (u, *) call wrt ("t2 * t1", t2 .fuse. t1) call wrt ("a1 * t1", a1 .fuse. t1) call wrt ("a2 * t1", a2 .fuse. t1) call wrt ("o1 * t1", o1 .fuse. t1) call wrt ("o1 * t2", o1 .fuse. t2) write (u, *) call wrt ("a1 * a1", a1 .fuse. a1) write (u, *) call wrt ("a1 * a2", a1 .fuse. a2) call wrt ("a1 * o1", a1 .fuse. o1) call wrt ("a2 * o2", a2 .fuse. o2) write (u, *) call wrt ("a2 * a1", a2 .fuse. a1) call wrt ("o1 * a1", o1 .fuse. a1) call wrt ("o2 * a2", o2 .fuse. a2) write (u, *) call wrt ("o1 * o1", o1 .fuse. o1) write (u, *) call wrt ("o1 * o2", o1 .fuse. o2) call wrt ("o1 * o3", o1 .fuse. o3) call wrt ("o1 * o4", o1 .fuse. o4) write (u, *) call wrt ("o2 * o1", o2 .fuse. o1) call wrt ("o3 * o1", o3 .fuse. o1) call wrt ("o4 * o1", o4 .fuse. o1) write (u, *) call wrt ("g1 * g1", g1 .fuse. g1) write (u, *) call wrt ("g1 * s1", g1 .fuse. s1) call wrt ("g1 * t1", g1 .fuse. t1) call wrt ("g1 * a1", g1 .fuse. a1) call wrt ("g1 * o1", g1 .fuse. o1) write (u, *) call wrt ("s1 * g1", s1 .fuse. g1) call wrt ("t1 * g1", t1 .fuse. g1) call wrt ("a1 * g1", a1 .fuse. g1) call wrt ("o1 * g1", o1 .fuse. g1) write (u, "(A)") write (u, "(A)") "* Test output end: color_2" contains subroutine wrt (s, col) character(*), intent(in) :: s class(color_t), intent(in) :: col write (u, "(A,1x,'=',1x)", advance="no") s call col%write (u) write (u, *) end subroutine wrt end subroutine color_2 @ %def color_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{The Madgraph color model} This section describes the method for matrix element and color flow calculation within Madgraph. For each Feynman diagram, the colorless amplitude for a specified helicity and momentum configuration (in- and out- combined) is computed: \begin{equation} A_d(p,h) \end{equation} Inserting color, the squared matrix element for definite helicity and momentum is \begin{equation} M^2(p,h) = \sum_{dd'} A_{d}(p,h)\,C_{dd'} A_{d'}^*(p,h) \end{equation} where $C_{dd'}$ describes the color interference of the two diagrams $A_d$ and $A_d'$, which is independent of momentum and helicity and can be calculated for each Feynman diagram pair by reducing it to the corresponding color graph. Obviously, one could combine all diagrams with identical color structure, such that the index $d$ runs only over different color graphs. For colorless diagrams all elements of $C_{dd'}$ are equal to unity. The hermitian matrix $C_{dd'}$ is diagonalized once and for all, such that it can be written in the form \begin{equation} C_{dd'} = \sum_\lambda c_d^\lambda \lambda\, c_d^\lambda{}^*, \end{equation} where the eigenvectors $c_d$ are normalized, \begin{equation} \sum_d |c_d^\lambda|^2 = 1, \end{equation} and the $\lambda$ values are the corresponding eigenvalues. In the colorless case, this means $c_d = 1/\sqrt{N_d}$ for all diagrams ($N_d=$ number of diagrams), and $\lambda=N_d$ is the only nonzero eigenvalue. Consequently, the squared matrix element for definite helicity and momentum can also be written as \begin{equation} M^2(p,h) = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h)^* \end{equation} with \begin{equation} A_\lambda(p,h) = \sum_d c_d^\lambda A_d(p,h). \end{equation} For generic spin density matrices, this is easily generalized to \begin{equation} M^2(p,h,h') = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^* \end{equation} To determine the color flow probabilities of a given momentum-helicity configuration, the color flow amplitudes are calculated as \begin{equation} a_f(p,h) = \sum_d \beta^f_d A_d(p,h), \end{equation} where the coefficients $\beta^f_d$ describe the amplitude for a given Feynman diagram (or color graph) $d$ to correspond to a definite color flow~$f$. They are computed from $C_{dd'}$ by transforming this matrix into the color flow basis and neglecting all off-diagonal elements. Again, these coefficients do not depend on momentum or helicity and can therefore be calculated in advance. This gives the color flow transition matrix \begin{equation} F^f(p,h,h') = a_f(p,h)\, a^*_f(p,h') \end{equation} which is assumed diagonal in color flow space and is separate from the color-summed transition matrix $M^2$. They are, however, equivalent (up to a factor) to leading order in $1/N_c$, and using the color flow transition matrix is appropriate for matching to hadronization. Note that the color flow transition matrix is not normalized at this stage. To make use of it, we have to fold it with the in-state density matrix to get a pseudo density matrix \begin{equation} \hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out}) = \sum_{h_{\rm in} h'_{\rm in}} F^f(p,h,h')\, \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \end{equation} which gets a meaning only after contracted with projections on the outgoing helicity states $k_{\rm out}$, given as linear combinations of helicity states with the unitary coefficient matrix $c(k_{\rm out}, h_{\rm out})$. Then the probability of finding color flow $f$ when the helicity state $k_{\rm out}$ is measured is given by \begin{equation} P^f(p, k_{\rm out}) = Q^f(p, k_{\rm out}) / \sum_f Q^f(p, k_{\rm out}) \end{equation} where \begin{equation} Q^f(p, k_{\rm out}) = \sum_{h_{\rm out} h'_{\rm out}} c(k_{\rm out}, h_{\rm out})\, \hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})\, c^*(k_{\rm out}, h'_{\rm out}) \end{equation} However, if we can assume that the out-state helicity basis is the canonical one, we can throw away the off diagonal elements in the color flow density matrix and normalize the ones on the diagonal to obtain \begin{equation} P^f(p, h_{\rm out}) = \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) / \sum_f \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) \end{equation} Finally, the color-summed out-state density matrix is computed by the scattering formula \begin{align} {\rho_{\rm out}(p,h_{\rm out},h'_{\rm out})} &= \sum_{h_{\rm in} h'_{\rm in}} M^2(p,h,h')\, \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \\ &= \sum_{h_{\rm in} h'_{\rm in} \lambda} A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^* \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}), \end{align} The trace of $\rho_{\rm out}$ is the squared matrix element, summed over all internal degrees of freedom. To get the squared matrix element for a definite helicity $k_{\rm out}$ and color flow $f$, one has to project the density matrix onto the given helicity state and multiply with $P^f(p, k_{\rm out})$. For diagonal helicities the out-state density reduces to \begin{equation} \rho_{\rm out}(p,h_{\rm out}) = \sum_{h_{\rm in}\lambda} \lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}). \end{equation} Since no basis transformation is involved, we can use the normalized color flow probability $P^f(p, h_{\rm out})$ and express the result as \begin{align} \rho_{\rm out}^f(p,h_{\rm out}) &= \rho_{\rm out}(p,h_{\rm out})\,P^f(p, h_{\rm out}) \\ &= \sum_{h_{\rm in}\lambda} \frac{|a^f(p,h)|^2}{\sum_f|a^f(p,h)|^2} \lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}). \end{align} From these considerations, the following calculation strategy can be derived: \begin{itemize} \item Before the first event is generated, the color interference matrix $C_{dd'}$ is computed and diagonalized, so the eigenvectors $c^\lambda_d$, eigenvalues $\lambda$ and color flow coefficients $\beta^f_d$ are obtained. In practice, these calculations are done when the matrix element code is generated, and the results are hardcoded in the matrix element subroutine as [[DATA]] statements. \item For each event, one loops over helicities once and stores the matrices $A_\lambda(p,h)$ and $a^f(p,h)$. The allowed color flows, helicity combinations and eigenvalues are each labeled by integer indices, so one has to store complex matrices of dimension $N_\lambda\times N_h$ and $N_f\times N_h$, respectively. \item The further strategy depends on the requested information. \begin{enumerate} \item If colorless diagonal helicity amplitudes are required, the eigenvalues $A_\lambda(p,h)$ are squared, summed with weight $\lambda$, and the result contracted with the in-state probability vector $\rho_{\rm in}(p, h_{\rm in})$. The result is a probability vector $\rho_{\rm out}(p, h_{\rm out})$. \item For colored diagonal helicity amplitudes, the color coefficients $a^f(p,h)$ are also squared and used as weights to obtain the color-flow probability vector $\rho_{\rm out}^f(p, h_{\rm out})$. \item For colorless non-diagonal helicity amplitudes, we contract the tensor product of $A_\lambda(p,h)$ with $A_\lambda(p,h')$, weighted with $\lambda$, with the correlated in-state density matrix, to obtain a correlated out-state density matrix. \item In the general (colored, non-diagonal) case, we do the same as in the colorless case, but return the un-normalized color flow density matrix $\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})$ in addition. When the relevant helicity basis is known, the latter can be used by the caller program to determine flow probabilities. (In reality, we assume the canonical basis and reduce the correlated out-state density to its diagonal immediately.) \end{enumerate} \end{itemize} @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Flavors: Particle properties} This module contains a type for holding the flavor code, and all functions that depend on the model, i.e., that determine particle properties. The PDG code is packed in a special [[flavor]] type. (This prohibits meaningless operations, and it allows for a different implementation, e.g., some non-PDG scheme internally, if appropiate at some point.) There are lots of further particle properties that depend on the model. Implementing a flyweight pattern, the associated field data object is to be stored in a central area, the [[flavor]] object just receives a pointer to this, so all queries can be delegated. <<[[flavors.f90]]>>= <> module flavors <> <> use io_units use diagnostics use physics_defs, only: UNDEFINED use physics_defs, only: INVALID use physics_defs, only: HADRON_REMNANT use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use model_data use colors, only: color_t <> <> <> <> contains <> end module flavors @ %def flavors @ \subsection{The flavor type} The flavor type is an integer representing the PDG code, or undefined (zero). Negative codes represent antiflavors. They should be used only for particles which do have a distinct antiparticle. The [[hard_process]] flag can be set for particles that are participating in the hard interaction. The [[radiated]] flag can be set for particles that are the result of a beam-structure interaction (hadron beam remnant, ISR photon, etc.), not of the hard interaction itself. Further properties of the given flavor can be retrieved via the particle-data pointer, if it is associated. <>= public :: flavor_t <>= type :: flavor_t private integer :: f = UNDEFINED logical :: hard_process = .false. logical :: radiated = .false. type(field_data_t), pointer :: field_data => null () contains <> end type flavor_t @ %def flavor_t @ Initializer form. If the model is assigned, the procedure is impure, therefore we have to define a separate array version. Note: The pure elemental subroutines can't have an intent(out) CLASS argument (because of the potential for an impure finalizer in a type extension), so we stick to intent(inout) and (re)set all components explicitly. <>= generic :: init => & flavor_init_empty, & flavor_init, & flavor_init_field_data, & flavor_init_model, & flavor_init_model_alt, & flavor_init_name_model procedure, private :: flavor_init_empty procedure, private :: flavor_init procedure, private :: flavor_init_field_data procedure, private :: flavor_init_model procedure, private :: flavor_init_model_alt procedure, private :: flavor_init_name_model <>= elemental subroutine flavor_init_empty (flv) class(flavor_t), intent(inout) :: flv flv%f = UNDEFINED flv%hard_process = .false. flv%radiated = .false. flv%field_data => null () end subroutine flavor_init_empty elemental subroutine flavor_init (flv, f) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => null () end subroutine flavor_init impure elemental subroutine flavor_init_field_data (flv, field_data) class(flavor_t), intent(inout) :: flv type(field_data_t), intent(in), target :: field_data flv%f = field_data%get_pdg () flv%hard_process = .false. flv%radiated = .false. flv%field_data => field_data end subroutine flavor_init_field_data impure elemental subroutine flavor_init_model (flv, f, model) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f class(model_data_t), intent(in), target :: model flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (f, check=.true.) end subroutine flavor_init_model impure elemental subroutine flavor_init_model_alt (flv, f, model, alt_model) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f class(model_data_t), intent(in), target :: model, alt_model flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (f, check=.false.) if (.not. associated (flv%field_data)) then flv%field_data => alt_model%get_field_ptr (f, check=.false.) if (.not. associated (flv%field_data)) then write (msg_buffer, "(A,1x,I0,1x,A,1x,A,1x,A,1x,A)") & "Particle with code", f, & "found neither in model", char (model%get_name ()), & "nor in model", char (alt_model%get_name ()) call msg_fatal () end if end if end subroutine flavor_init_model_alt impure elemental subroutine flavor_init_name_model (flv, name, model) class(flavor_t), intent(inout) :: flv type(string_t), intent(in) :: name class(model_data_t), intent(in), target :: model flv%f = model%get_pdg (name) flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (name, check=.true.) end subroutine flavor_init_name_model @ %def flavor_init @ Set the [[radiated]] flag. <>= procedure :: tag_radiated => flavor_tag_radiated <>= elemental subroutine flavor_tag_radiated (flv) class(flavor_t), intent(inout) :: flv flv%radiated = .true. end subroutine flavor_tag_radiated @ %def flavor_tag_radiated @ Set the [[hard_process]] flag. <>= procedure :: tag_hard_process => flavor_tag_hard_process <>= elemental subroutine flavor_tag_hard_process (flv) class(flavor_t), intent(inout) :: flv flv%hard_process = .true. end subroutine flavor_tag_hard_process @ %def flavor_tag_hard_process @ Undefine the flavor state: <>= procedure :: undefine => flavor_undefine <>= elemental subroutine flavor_undefine (flv) class(flavor_t), intent(inout) :: flv flv%f = UNDEFINED flv%field_data => null () end subroutine flavor_undefine @ %def flavor_undefine @ Output: dense, no linebreak <>= procedure :: write => flavor_write <>= subroutine flavor_write (flv, unit) class(flavor_t), intent(in) :: flv integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (associated (flv%field_data)) then write (u, "(A)", advance="no") "f(" else write (u, "(A)", advance="no") "p(" end if write (u, "(I0)", advance="no") flv%f if (flv%radiated) then write (u, "('*')", advance="no") end if write (u, "(A)", advance="no") ")" end subroutine flavor_write @ %def flavor_write @ <>= public :: flavor_write_array <>= subroutine flavor_write_array (flv, unit) type(flavor_t), intent(in), dimension(:) :: flv integer, intent(in), optional :: unit integer :: u, i_flv u = given_output_unit (unit); if (u < 0) return do i_flv = 1, size (flv) call flv(i_flv)%write (u) if (i_flv /= size (flv)) write (u,"(A)", advance = "no") " / " end do write (u,"(A)") end subroutine flavor_write_array @ %def flavor_write_array @ Binary I/O. Currently, the model information is not written/read, so after reading the particle-data pointer is empty. <>= procedure :: write_raw => flavor_write_raw procedure :: read_raw => flavor_read_raw <>= subroutine flavor_write_raw (flv, u) class(flavor_t), intent(in) :: flv integer, intent(in) :: u write (u) flv%f write (u) flv%radiated end subroutine flavor_write_raw subroutine flavor_read_raw (flv, u, iostat) class(flavor_t), intent(out) :: flv integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) flv%f if (present (iostat)) then if (iostat /= 0) return end if read (u, iostat=iostat) flv%radiated end subroutine flavor_read_raw @ %def flavor_write_raw flavor_read_raw @ \subsubsection{Assignment} Default assignment of flavor objects is possible, but cannot be used in pure procedures, because a pointer assignment is involved. Assign the particle pointer separately. This cannot be elemental, so we define a scalar and an array version explicitly. We refer to an array of flavors, not an array of models. <>= procedure :: set_model => flavor_set_model_single <>= impure elemental subroutine flavor_set_model_single (flv, model) class(flavor_t), intent(inout) :: flv class(model_data_t), intent(in), target :: model if (flv%f /= UNDEFINED) & flv%field_data => model%get_field_ptr (flv%f) end subroutine flavor_set_model_single @ %def flavor_set_model @ \subsubsection{Predicates} Return the definition status. By definition, the flavor object is defined if the flavor PDG code is nonzero. <>= procedure :: is_defined => flavor_is_defined <>= elemental function flavor_is_defined (flv) result (defined) class(flavor_t), intent(in) :: flv logical :: defined defined = flv%f /= UNDEFINED end function flavor_is_defined @ %def flavor_is_defined @ Check for valid flavor (including undefined). This is distinct from the [[is_defined]] status. Invalid flavor is actually a specific PDG code. <>= procedure :: is_valid => flavor_is_valid <>= elemental function flavor_is_valid (flv) result (valid) class(flavor_t), intent(in) :: flv logical :: valid valid = flv%f /= INVALID end function flavor_is_valid @ %def flavor_is_valid @ Return true if the particle-data pointer is associated. (Debugging aid) <>= procedure :: is_associated => flavor_is_associated <>= elemental function flavor_is_associated (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = associated (flv%field_data) end function flavor_is_associated @ %def flavor_is_associated @ Check the [[radiated]] flag. A radiated particle has a definite PDG flavor status, but it is actually a pseudoparticle (a beam remnant) which may be subject to fragmentation. <>= procedure :: is_radiated => flavor_is_radiated <>= elemental function flavor_is_radiated (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = flv%radiated end function flavor_is_radiated @ %def flavor_is_radiated @ Check the [[hard_process]] flag. A particle is tagged with this flag if it participates in the hard interaction and is not a beam remnant. <>= procedure :: is_hard_process => flavor_is_hard_process <>= elemental function flavor_is_hard_process (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = flv%hard_process end function flavor_is_hard_process @ %def flavor_is_hard_process @ \subsubsection{Accessing contents} With the exception of the PDG code, all particle property enquiries are delegated to the [[field_data]] pointer. If this is unassigned, some access function will crash. Return the flavor as an integer <>= procedure :: get_pdg => flavor_get_pdg <>= elemental function flavor_get_pdg (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv f = flv%f end function flavor_get_pdg @ %def flavor_get_pdg @ Return the flavor of the antiparticle <>= procedure :: get_pdg_anti => flavor_get_pdg_anti <>= elemental function flavor_get_pdg_anti (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%field_data%has_antiparticle ()) then f = -flv%f else f = flv%f end if else f = 0 end if end function flavor_get_pdg_anti @ %def flavor_get_pdg_anti @ Absolute value: <>= procedure :: get_pdg_abs => flavor_get_pdg_abs <>= elemental function flavor_get_pdg_abs (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv f = abs (flv%f) end function flavor_get_pdg_abs @ %def flavor_get_pdg_abs @ Generic properties <>= procedure :: is_visible => flavor_is_visible procedure :: is_parton => flavor_is_parton procedure :: is_beam_remnant => flavor_is_beam_remnant procedure :: is_gauge => flavor_is_gauge procedure :: is_left_handed => flavor_is_left_handed procedure :: is_right_handed => flavor_is_right_handed procedure :: is_antiparticle => flavor_is_antiparticle procedure :: has_antiparticle => flavor_has_antiparticle procedure :: is_stable => flavor_is_stable procedure :: get_decays => flavor_get_decays procedure :: decays_isotropically => flavor_decays_isotropically procedure :: decays_diagonal => flavor_decays_diagonal procedure :: has_decay_helicity => flavor_has_decay_helicity procedure :: get_decay_helicity => flavor_get_decay_helicity procedure :: is_polarized => flavor_is_polarized <>= elemental function flavor_is_visible (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_visible () else flag = .false. end if end function flavor_is_visible elemental function flavor_is_parton (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_parton () else flag = .false. end if end function flavor_is_parton elemental function flavor_is_beam_remnant (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv select case (abs (flv%f)) case (HADRON_REMNANT, & HADRON_REMNANT_SINGLET, HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET) flag = .true. case default flag = .false. end select end function flavor_is_beam_remnant elemental function flavor_is_gauge (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_gauge () else flag = .false. end if end function flavor_is_gauge elemental function flavor_is_left_handed (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%f > 0) then flag = flv%field_data%is_left_handed () else flag = flv%field_data%is_right_handed () end if else flag = .false. end if end function flavor_is_left_handed elemental function flavor_is_right_handed (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%f > 0) then flag = flv%field_data%is_right_handed () else flag = flv%field_data%is_left_handed () end if else flag = .false. end if end function flavor_is_right_handed elemental function flavor_is_antiparticle (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv flag = flv%f < 0 end function flavor_is_antiparticle elemental function flavor_has_antiparticle (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%has_antiparticle () else flag = .false. end if end function flavor_has_antiparticle elemental function flavor_is_stable (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_stable (anti = flv%f < 0) else flag = .true. end if end function flavor_is_stable subroutine flavor_get_decays (flv, decay) class(flavor_t), intent(in) :: flv type(string_t), dimension(:), intent(out), allocatable :: decay logical :: anti anti = flv%f < 0 if (.not. flv%field_data%is_stable (anti)) then call flv%field_data%get_decays (decay, anti) end if end subroutine flavor_get_decays elemental function flavor_decays_isotropically (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%decays_isotropically (anti = flv%f < 0) else flag = .true. end if end function flavor_decays_isotropically elemental function flavor_decays_diagonal (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%decays_diagonal (anti = flv%f < 0) else flag = .true. end if end function flavor_decays_diagonal elemental function flavor_has_decay_helicity (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%has_decay_helicity (anti = flv%f < 0) else flag = .false. end if end function flavor_has_decay_helicity elemental function flavor_get_decay_helicity (flv) result (hel) integer :: hel class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then hel = flv%field_data%decay_helicity (anti = flv%f < 0) else hel = 0 end if end function flavor_get_decay_helicity elemental function flavor_is_polarized (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_polarized (anti = flv%f < 0) else flag = .false. end if end function flavor_is_polarized @ %def flavor_is_visible @ %def flavor_is_parton @ %def flavor_is_beam_remnant @ %def flavor_is_gauge @ %def flavor_is_left_handed @ %def flavor_is_right_handed @ %def flavor_is_antiparticle @ %def flavor_has_antiparticle @ %def flavor_is_stable @ %def flavor_get_decays @ %def flavor_decays_isotropically @ %def flavor_decays_diagonal @ %def flavor_has_decays_helicity @ %def flavor_get_decay_helicity @ %def flavor_is_polarized @ Names: <>= procedure :: get_name => flavor_get_name procedure :: get_tex_name => flavor_get_tex_name <>= elemental function flavor_get_name (flv) result (name) type(string_t) :: name class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then name = flv%field_data%get_name (flv%f < 0) else name = "?" end if end function flavor_get_name elemental function flavor_get_tex_name (flv) result (name) type(string_t) :: name class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then name = flv%field_data%get_tex_name (flv%f < 0) else name = "?" end if end function flavor_get_tex_name @ %def flavor_get_name flavor_get_tex_name <>= procedure :: get_spin_type => flavor_get_spin_type procedure :: get_multiplicity => flavor_get_multiplicity procedure :: get_isospin_type => flavor_get_isospin_type procedure :: get_charge_type => flavor_get_charge_type procedure :: get_color_type => flavor_get_color_type <>= elemental function flavor_get_spin_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_spin_type () else type = 1 end if end function flavor_get_spin_type elemental function flavor_get_multiplicity (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_multiplicity () else type = 1 end if end function flavor_get_multiplicity elemental function flavor_get_isospin_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_isospin_type () else type = 1 end if end function flavor_get_isospin_type elemental function flavor_get_charge_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_charge_type () else type = 1 end if end function flavor_get_charge_type elemental function flavor_get_color_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flavor_is_antiparticle (flv)) then type = - flv%field_data%get_color_type () else type = flv%field_data%get_color_type () end if select case (type) case (-1,-8); type = abs (type) end select else type = 1 end if end function flavor_get_color_type @ %def flavor_get_spin_type @ %def flavor_get_multiplicity @ %def flavor_get_isospin_type @ %def flavor_get_charge_type @ %def flavor_get_color_type @ These functions return real values: <>= procedure :: get_charge => flavor_get_charge procedure :: get_mass => flavor_get_mass procedure :: get_width => flavor_get_width procedure :: get_isospin => flavor_get_isospin <>= elemental function flavor_get_charge (flv) result (charge) real(default) :: charge class(flavor_t), intent(in) :: flv integer :: charge_type if (associated (flv%field_data)) then charge_type = flv%get_charge_type () if (charge_type == 0 .or. charge_type == 1) then charge = 0 else if (flavor_is_antiparticle (flv)) then charge = - flv%field_data%get_charge () else charge = flv%field_data%get_charge () end if end if else charge = 0 end if end function flavor_get_charge elemental function flavor_get_mass (flv) result (mass) real(default) :: mass class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then mass = flv%field_data%get_mass () else mass = 0 end if end function flavor_get_mass elemental function flavor_get_width (flv) result (width) real(default) :: width class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then width = flv%field_data%get_width () else width = 0 end if end function flavor_get_width elemental function flavor_get_isospin (flv) result (isospin) real(default) :: isospin class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flavor_is_antiparticle (flv)) then isospin = - flv%field_data%get_isospin () else isospin = flv%field_data%get_isospin () end if else isospin = 0 end if end function flavor_get_isospin @ %def flavor_get_charge flavor_get_mass flavor_get_width @ %def flavor_get_isospin @ \subsubsection{Comparisons} If one of the flavors is undefined, the other defined, they match. <>= generic :: operator(.match.) => flavor_match generic :: operator(==) => flavor_eq generic :: operator(/=) => flavor_neq procedure, private :: flavor_match procedure, private :: flavor_eq procedure, private :: flavor_neq @ %def .match. == /= <>= elemental function flavor_match (flv1, flv2) result (eq) logical :: eq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then eq = flv1%f == flv2%f else eq = .true. end if end function flavor_match elemental function flavor_eq (flv1, flv2) result (eq) logical :: eq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then eq = flv1%f == flv2%f else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then eq = .true. else eq = .false. end if end function flavor_eq @ %def flavor_match flavor_eq <>= elemental function flavor_neq (flv1, flv2) result (neq) logical :: neq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then neq = flv1%f /= flv2%f else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then neq = .false. else neq = .true. end if end function flavor_neq @ %def flavor_neq @ \subsubsection{Tools} Merge two flavor indices. This works only if both are equal or either one is undefined, because we have no off-diagonal flavor entries. Otherwise, generate an invalid flavor. We cannot use elemental procedures because of the pointer component. <>= public :: operator(.merge.) <>= interface operator(.merge.) module procedure merge_flavors0 module procedure merge_flavors1 end interface @ %def .merge. <>= function merge_flavors0 (flv1, flv2) result (flv) type(flavor_t) :: flv type(flavor_t), intent(in) :: flv1, flv2 if (flavor_is_defined (flv1) .and. flavor_is_defined (flv2)) then if (flv1 == flv2) then flv = flv1 else flv%f = INVALID end if else if (flavor_is_defined (flv1)) then flv = flv1 else if (flavor_is_defined (flv2)) then flv = flv2 end if end function merge_flavors0 function merge_flavors1 (flv1, flv2) result (flv) type(flavor_t), dimension(:), intent(in) :: flv1, flv2 type(flavor_t), dimension(size(flv1)) :: flv integer :: i do i = 1, size (flv1) flv(i) = flv1(i) .merge. flv2(i) end do end function merge_flavors1 @ %def merge_flavors @ Generate consecutive color indices for a given flavor. The indices are counted starting with the stored value of c, so new indices are created each time this (impure) function is called. The counter can be reset by the optional argument [[c_seed]] if desired. The optional flag [[reverse]] is used only for octets. If set, the color and anticolor entries of the octet particle are exchanged. <>= public :: color_from_flavor <>= interface color_from_flavor module procedure color_from_flavor0 module procedure color_from_flavor1 end interface <>= function color_from_flavor0 (flv, c_seed, reverse) result (col) type(color_t) :: col type(flavor_t), intent(in) :: flv integer, intent(in), optional :: c_seed logical, intent(in), optional :: reverse integer, save :: c = 1 logical :: rev if (present (c_seed)) c = c_seed rev = .false.; if (present (reverse)) rev = reverse select case (flavor_get_color_type (flv)) case (1) call col%init () case (3) call col%init ([c]); c = c + 1 case (-3) call col%init ([-c]); c = c + 1 case (8) if (rev) then call col%init ([c+1, -c]); c = c + 2 else call col%init ([c, -(c+1)]); c = c + 2 end if end select end function color_from_flavor0 function color_from_flavor1 (flv, c_seed, reverse) result (col) type(flavor_t), dimension(:), intent(in) :: flv integer, intent(in), optional :: c_seed logical, intent(in), optional :: reverse type(color_t), dimension(size(flv)) :: col integer :: i col(1) = color_from_flavor0 (flv(1), c_seed, reverse) do i = 2, size (flv) col(i) = color_from_flavor0 (flv(i), reverse=reverse) end do end function color_from_flavor1 @ %def color_from_flavor @ This procedure returns the flavor object for the antiparticle. The antiparticle code may either be the same code or its negative. <>= procedure :: anti => flavor_anti <>= function flavor_anti (flv) result (aflv) type(flavor_t) :: aflv class(flavor_t), intent(in) :: flv if (flavor_has_antiparticle (flv)) then aflv%f = - flv%f else aflv%f = flv%f end if aflv%field_data => flv%field_data end function flavor_anti @ %def flavor_anti @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Quantum numbers} This module collects helicity, color, and flavor in a single type and defines procedures <<[[quantum_numbers.f90]]>>= <> module quantum_numbers use io_units use model_data use helicities use colors use flavors <> <> <> <> contains <> end module quantum_numbers @ %def quantum_numbers @ \subsection{The quantum number type} <>= public :: quantum_numbers_t <>= type :: quantum_numbers_t private type(flavor_t) :: f type(color_t) :: c type(helicity_t) :: h integer :: sub = 0 contains <> end type quantum_numbers_t @ %def quantum_number_t @ Define quantum numbers: Initializer form. All arguments may be present or absent. Some elemental initializers are impure because they set the [[flv]] component. This implies transfer of a pointer behind the scenes. <>= generic :: init => & quantum_numbers_init_f, & quantum_numbers_init_c, & quantum_numbers_init_h, & quantum_numbers_init_fc, & quantum_numbers_init_fh, & quantum_numbers_init_ch, & quantum_numbers_init_fch, & quantum_numbers_init_fs, & quantum_numbers_init_fhs, & quantum_numbers_init_fcs, & quantum_numbers_init_fhcs procedure, private :: quantum_numbers_init_f procedure, private :: quantum_numbers_init_c procedure, private :: quantum_numbers_init_h procedure, private :: quantum_numbers_init_fc procedure, private :: quantum_numbers_init_fh procedure, private :: quantum_numbers_init_ch procedure, private :: quantum_numbers_init_fch procedure, private :: quantum_numbers_init_fs procedure, private :: quantum_numbers_init_fhs procedure, private :: quantum_numbers_init_fcs procedure, private :: quantum_numbers_init_fhcs <>= impure elemental subroutine quantum_numbers_init_f (qn, flv) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv qn%f = flv call qn%c%undefine () call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_f impure elemental subroutine quantum_numbers_init_c (qn, col) class(quantum_numbers_t), intent(out) :: qn type(color_t), intent(in) :: col call qn%f%undefine () qn%c = col call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_c impure elemental subroutine quantum_numbers_init_h (qn, hel) class(quantum_numbers_t), intent(out) :: qn type(helicity_t), intent(in) :: hel call qn%f%undefine () call qn%c%undefine () qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_h impure elemental subroutine quantum_numbers_init_fc (qn, flv, col) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col qn%f = flv qn%c = col call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_fc impure elemental subroutine quantum_numbers_init_fh (qn, flv, hel) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel qn%f = flv call qn%c%undefine () qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_fh impure elemental subroutine quantum_numbers_init_ch (qn, col, hel) class(quantum_numbers_t), intent(out) :: qn type(color_t), intent(in) :: col type(helicity_t), intent(in) :: hel call qn%f%undefine () qn%c = col qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_ch impure elemental subroutine quantum_numbers_init_fch (qn, flv, col, hel) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col type(helicity_t), intent(in) :: hel qn%f = flv qn%c = col qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_fch impure elemental subroutine quantum_numbers_init_fs (qn, flv, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv integer, intent(in) :: sub qn%f = flv; qn%sub = sub end subroutine quantum_numbers_init_fs impure elemental subroutine quantum_numbers_init_fhs (qn, flv, hel, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel integer, intent(in) :: sub qn%f = flv; qn%h = hel; qn%sub = sub end subroutine quantum_numbers_init_fhs impure elemental subroutine quantum_numbers_init_fcs (qn, flv, col, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col integer, intent(in) :: sub qn%f = flv; qn%c = col; qn%sub = sub end subroutine quantum_numbers_init_fcs impure elemental subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel type(color_t), intent(in) :: col integer, intent(in) :: sub qn%f = flv; qn%h = hel; qn%c = col; qn%sub = sub end subroutine quantum_numbers_init_fhcs @ %def quantum_numbers_init @ \subsection{I/O} Write the quantum numbers in condensed form, enclosed by square brackets. Color is written only if nontrivial. For convenience, introduce also an array version. If the [[col_verbose]] option is set, show the quantum number color also if it is zero, but defined. Otherwise, suppress zero color. <>= public :: quantum_numbers_write <>= procedure :: write => quantum_numbers_write_single <>= interface quantum_numbers_write module procedure quantum_numbers_write_single module procedure quantum_numbers_write_array end interface <>= subroutine quantum_numbers_write_single (qn, unit, col_verbose) class(quantum_numbers_t), intent(in) :: qn integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: u logical :: col_verb u = given_output_unit (unit); if (u < 0) return col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose write (u, "(A)", advance = "no") "[" if (qn%f%is_defined ()) then call qn%f%write (u) if (qn%c%is_nonzero () .or. qn%h%is_defined ()) & write (u, "(1x)", advance = "no") end if if (col_verb) then if (qn%c%is_defined () .or. qn%c%is_ghost ()) then call color_write (qn%c, u) if (qn%h%is_defined ()) write (u, "(1x)", advance = "no") end if else if (qn%c%is_nonzero () .or. qn%c%is_ghost ()) then call color_write (qn%c, u) if (qn%h%is_defined ()) write (u, "(1x)", advance = "no") end if end if if (qn%h%is_defined ()) then call qn%h%write (u) end if if (qn%sub > 0) & write (u, "(A,I0)", advance = "no") " SUB = ", qn%sub write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_write_single subroutine quantum_numbers_write_array (qn, unit, col_verbose) type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: i integer :: u logical :: col_verb u = given_output_unit (unit); if (u < 0) return col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose write (u, "(A)", advance="no") "[" do i = 1, size (qn) if (i > 1) write (u, "(A)", advance="no") " / " if (qn(i)%f%is_defined ()) then call qn(i)%f%write (u) if (qn(i)%c%is_nonzero () .or. qn(i)%h%is_defined ()) & write (u, "(1x)", advance="no") end if if (col_verb) then if (qn(i)%c%is_defined () .or. qn(i)%c%is_ghost ()) then call color_write (qn(i)%c, u) if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no") end if else if (qn(i)%c%is_nonzero () .or. qn(i)%c%is_ghost ()) then call color_write (qn(i)%c, u) if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no") end if end if if (qn(i)%h%is_defined ()) then call qn(i)%h%write (u) end if if (qn(i)%sub > 0) & write (u, "(A,I2)", advance = "no") " SUB = ", qn(i)%sub end do write (u, "(A)", advance = "no") "]" end subroutine quantum_numbers_write_array @ %def quantum_numbers_write @ Binary I/O. <>= procedure :: write_raw => quantum_numbers_write_raw procedure :: read_raw => quantum_numbers_read_raw <>= subroutine quantum_numbers_write_raw (qn, u) class(quantum_numbers_t), intent(in) :: qn integer, intent(in) :: u call qn%f%write_raw (u) call qn%c%write_raw (u) call qn%h%write_raw (u) end subroutine quantum_numbers_write_raw subroutine quantum_numbers_read_raw (qn, u, iostat) class(quantum_numbers_t), intent(out) :: qn integer, intent(in) :: u integer, intent(out), optional :: iostat call qn%f%read_raw (u, iostat=iostat) call qn%c%read_raw (u, iostat=iostat) call qn%h%read_raw (u, iostat=iostat) end subroutine quantum_numbers_read_raw @ %def quantum_numbers_write_raw quantum_numbers_read_raw @ \subsection{Accessing contents} Color and helicity can be done by elemental functions. Flavor needs impure elemental. We export also the functions directly, this allows us to avoid temporaries in some places. <>= public :: quantum_numbers_get_flavor public :: quantum_numbers_get_color public :: quantum_numbers_get_helicity <>= procedure :: get_flavor => quantum_numbers_get_flavor procedure :: get_color => quantum_numbers_get_color procedure :: get_helicity => quantum_numbers_get_helicity procedure :: get_sub => quantum_numbers_get_sub <>= impure elemental function quantum_numbers_get_flavor (qn) result (flv) type(flavor_t) :: flv class(quantum_numbers_t), intent(in) :: qn flv = qn%f end function quantum_numbers_get_flavor elemental function quantum_numbers_get_color (qn) result (col) type(color_t) :: col class(quantum_numbers_t), intent(in) :: qn col = qn%c end function quantum_numbers_get_color elemental function quantum_numbers_get_helicity (qn) result (hel) type(helicity_t) :: hel class(quantum_numbers_t), intent(in) :: qn hel = qn%h end function quantum_numbers_get_helicity elemental function quantum_numbers_get_sub (qn) result (sub) integer :: sub class(quantum_numbers_t), intent(in) :: qn sub = qn%sub end function quantum_numbers_get_sub @ %def quantum_numbers_get_flavor @ %def quantum_numbers_get_color @ %def quantum_numbers_get_helicity @ %def quantum_numbers_get_sub @ This just resets the ghost property of the color part: <>= procedure :: set_color_ghost => quantum_numbers_set_color_ghost <>= elemental subroutine quantum_numbers_set_color_ghost (qn, ghost) class(quantum_numbers_t), intent(inout) :: qn logical, intent(in) :: ghost call qn%c%set_ghost (ghost) end subroutine quantum_numbers_set_color_ghost @ %def quantum_numbers_set_color_ghost @ Assign a model to the flavor part of quantum numbers. <>= procedure :: set_model => quantum_numbers_set_model <>= impure elemental subroutine quantum_numbers_set_model (qn, model) class(quantum_numbers_t), intent(inout) :: qn class(model_data_t), intent(in), target :: model call qn%f%set_model (model) end subroutine quantum_numbers_set_model @ %def quantum_numbers_set_model @ Set the [[radiated]] flag for the flavor component. <>= procedure :: tag_radiated => quantum_numbers_tag_radiated <>= elemental subroutine quantum_numbers_tag_radiated (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%f%tag_radiated () end subroutine quantum_numbers_tag_radiated @ %def quantum_numbers_tag_radiated @ Set the [[hard_process]] flag for the flavor component. <>= procedure :: tag_hard_process => quantum_numbers_tag_hard_process <>= elemental subroutine quantum_numbers_tag_hard_process (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%f%tag_hard_process () end subroutine quantum_numbers_tag_hard_process @ %def quantum_numbers_tag_hard_process @ <>= procedure :: set_subtraction_index => quantum_numbers_set_subtraction_index <>= elemental subroutine quantum_numbers_set_subtraction_index (qn, i) class(quantum_numbers_t), intent(inout) :: qn integer, intent(in) :: i qn%sub = i end subroutine quantum_numbers_set_subtraction_index @ %def quantum_numbers_set_subtraction_index @ <>= procedure :: get_subtraction_index => quantum_numbers_get_subtraction_index <>= elemental function quantum_numbers_get_subtraction_index (qn) result (sub) integer :: sub class(quantum_numbers_t), intent(in) :: qn sub = qn%sub end function quantum_numbers_get_subtraction_index @ %def quantum_numbers_get_subtraction_index @ This is a convenience function: return the color type for the flavor (array). Note: keep the public version temporarily, this will be used in a complicated expression which triggers a compiler bug (nagfor 5.3) in the TBP version. <>= public :: quantum_numbers_get_color_type <>= procedure :: get_color_type => quantum_numbers_get_color_type <>= elemental function quantum_numbers_get_color_type (qn) result (color_type) integer :: color_type class(quantum_numbers_t), intent(in) :: qn color_type = qn%f%get_color_type () end function quantum_numbers_get_color_type @ %def quantum_numbers_get_color_type @ \subsection{Predicates} Check if the flavor index is valid (including UNDEFINED). <>= procedure :: are_valid => quantum_numbers_are_valid <>= elemental function quantum_numbers_are_valid (qn) result (valid) logical :: valid class(quantum_numbers_t), intent(in) :: qn valid = qn%f%is_valid () end function quantum_numbers_are_valid @ %def quantum_numbers_are_valid @ Check if the flavor part has its particle-data pointer associated (debugging aid). <>= procedure :: are_associated => quantum_numbers_are_associated <>= elemental function quantum_numbers_are_associated (qn) result (flag) logical :: flag class(quantum_numbers_t), intent(in) :: qn flag = qn%f%is_associated () end function quantum_numbers_are_associated @ %def quantum_numbers_are_associated @ Check if the helicity and color quantum numbers are diagonal. (Unpolarized/colorless also counts as diagonal.) Flavor is diagonal by definition. <>= procedure :: are_diagonal => quantum_numbers_are_diagonal <>= elemental function quantum_numbers_are_diagonal (qn) result (diagonal) logical :: diagonal class(quantum_numbers_t), intent(in) :: qn diagonal = qn%h%is_diagonal () .and. qn%c%is_diagonal () end function quantum_numbers_are_diagonal @ %def quantum_numbers_are_diagonal @ Check if the color part has the ghost property. <>= procedure :: is_color_ghost => quantum_numbers_is_color_ghost <>= elemental function quantum_numbers_is_color_ghost (qn) result (ghost) logical :: ghost class(quantum_numbers_t), intent(in) :: qn ghost = qn%c%is_ghost () end function quantum_numbers_is_color_ghost @ %def quantum_numbers_is_color_ghost @ Check if the flavor participates in the hard interaction. <>= procedure :: are_hard_process => quantum_numbers_are_hard_process <>= elemental function quantum_numbers_are_hard_process (qn) result (hard_process) logical :: hard_process class(quantum_numbers_t), intent(in) :: qn hard_process = qn%f%is_hard_process () end function quantum_numbers_are_hard_process @ %def quantum_numbers_are_hard_process @ \subsection{Comparisons} Matching and equality is derived from the individual quantum numbers. The variant [[fhmatch]] matches only flavor and helicity. The variant [[dhmatch]] matches only diagonal helicity, if the matching helicity is undefined. <>= public :: quantum_numbers_eq_wo_sub <>= generic :: operator(.match.) => quantum_numbers_match generic :: operator(.fmatch.) => quantum_numbers_match_f generic :: operator(.hmatch.) => quantum_numbers_match_h generic :: operator(.fhmatch.) => quantum_numbers_match_fh generic :: operator(.dhmatch.) => quantum_numbers_match_hel_diag generic :: operator(==) => quantum_numbers_eq generic :: operator(/=) => quantum_numbers_neq procedure, private :: quantum_numbers_match procedure, private :: quantum_numbers_match_f procedure, private :: quantum_numbers_match_h procedure, private :: quantum_numbers_match_fh procedure, private :: quantum_numbers_match_hel_diag procedure, private :: quantum_numbers_eq procedure, private :: quantum_numbers_neq @ %def .match. == /= <>= elemental function quantum_numbers_match (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%c .match. qn2%c) .and. & (qn1%h .match. qn2%h) end function quantum_numbers_match elemental function quantum_numbers_match_f (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) end function quantum_numbers_match_f elemental function quantum_numbers_match_h (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%h .match. qn2%h) end function quantum_numbers_match_h elemental function quantum_numbers_match_fh (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%h .match. qn2%h) end function quantum_numbers_match_fh elemental function quantum_numbers_match_hel_diag (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%c .match. qn2%c) .and. & (qn1%h .dmatch. qn2%h) end function quantum_numbers_match_hel_diag elemental function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq) logical :: eq type(quantum_numbers_t), intent(in) :: qn1, qn2 eq = (qn1%f == qn2%f) .and. & (qn1%c == qn2%c) .and. & (qn1%h == qn2%h) end function quantum_numbers_eq_wo_sub elemental function quantum_numbers_eq (qn1, qn2) result (eq) logical :: eq class(quantum_numbers_t), intent(in) :: qn1, qn2 eq = (qn1%f == qn2%f) .and. & (qn1%c == qn2%c) .and. & (qn1%h == qn2%h) .and. & (qn1%sub == qn2%sub) end function quantum_numbers_eq elemental function quantum_numbers_neq (qn1, qn2) result (neq) logical :: neq class(quantum_numbers_t), intent(in) :: qn1, qn2 neq = (qn1%f /= qn2%f) .or. & (qn1%c /= qn2%c) .or. & (qn1%h /= qn2%h) .or. & (qn1%sub /= qn2%sub) end function quantum_numbers_neq @ %def quantum_numbers_match @ %def quantum_numbers_eq @ %def quantum_numbers_neq <>= public :: assignment(=) <>= interface assignment(=) module procedure quantum_numbers_assign end interface <>= subroutine quantum_numbers_assign (qn_out, qn_in) type(quantum_numbers_t), intent(out) :: qn_out type(quantum_numbers_t), intent(in) :: qn_in qn_out%f = qn_in%f qn_out%c = qn_in%c qn_out%h = qn_in%h qn_out%sub = qn_in%sub end subroutine quantum_numbers_assign @ %def quantum_numbers_assign @ Two sets of quantum numbers are compatible if the individual quantum numbers are compatible, depending on the mask. Flavor has to match, regardless of the flavor mask. If the color flag is set, color is compatible if the ghost property is identical. If the color flag is unset, color has to be identical. I.e., if the flag is set, the color amplitudes can interfere. If it is not set, they must be identical, and there must be no ghost. The latter property is used for expanding physical color flows. Helicity is compatible if the mask is unset, otherwise it has to match. This determines if two amplitudes can be multiplied (no mask) or traced (mask). <>= public :: quantum_numbers_are_compatible <>= elemental function quantum_numbers_are_compatible (qn1, qn2, mask) & result (flag) logical :: flag type(quantum_numbers_t), intent(in) :: qn1, qn2 type(quantum_numbers_mask_t), intent(in) :: mask if (mask%h .or. mask%hd) then flag = (qn1%f .match. qn2%f) .and. (qn1%h .match. qn2%h) else flag = (qn1%f .match. qn2%f) end if if (mask%c) then flag = flag .and. (qn1%c%is_ghost () .eqv. qn2%c%is_ghost ()) else flag = flag .and. & .not. (qn1%c%is_ghost () .or. qn2%c%is_ghost ()) .and. & (qn1%c == qn2%c) end if end function quantum_numbers_are_compatible @ %def quantum_numbers_are_compatible @ This is the analog for a single quantum-number set. We just check for color ghosts; they are excluded if the color mask is unset (color-flow expansion). <>= public :: quantum_numbers_are_physical <>= elemental function quantum_numbers_are_physical (qn, mask) result (flag) logical :: flag type(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask if (mask%c) then flag = .true. else flag = .not. qn%c%is_ghost () end if end function quantum_numbers_are_physical @ %def quantum_numbers_are_physical @ \subsection{Operations} Inherited from the color component: reassign color indices in canonical order. <>= public :: quantum_numbers_canonicalize_color <>= subroutine quantum_numbers_canonicalize_color (qn) type(quantum_numbers_t), dimension(:), intent(inout) :: qn call color_canonicalize (qn%c) end subroutine quantum_numbers_canonicalize_color @ %def quantum_numbers_canonicalize_color @ Inherited from the color component: make a color map for two matching quantum-number arrays. <>= public :: make_color_map <>= interface make_color_map module procedure quantum_numbers_make_color_map end interface make_color_map <>= subroutine quantum_numbers_make_color_map (map, qn1, qn2) integer, dimension(:,:), intent(out), allocatable :: map type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2 call make_color_map (map, qn1%c, qn2%c) end subroutine quantum_numbers_make_color_map @ %def make_color_map @ Inherited from the color component: translate the color part using a color-map array <>= public :: quantum_numbers_translate_color <>= interface quantum_numbers_translate_color module procedure quantum_numbers_translate_color0 module procedure quantum_numbers_translate_color1 end interface <>= subroutine quantum_numbers_translate_color0 (qn, map, offset) type(quantum_numbers_t), intent(inout) :: qn integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset call color_translate (qn%c, map, offset) end subroutine quantum_numbers_translate_color0 subroutine quantum_numbers_translate_color1 (qn, map, offset) type(quantum_numbers_t), dimension(:), intent(inout) :: qn integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset call color_translate (qn%c, map, offset) end subroutine quantum_numbers_translate_color1 @ %def quantum_numbers_translate_color @ Inherited from the color component: return the color index with highest absolute value. Since the algorithm is not elemental, we keep the separate procedures for different array rank. <>= public :: quantum_numbers_get_max_color_value <>= interface quantum_numbers_get_max_color_value module procedure quantum_numbers_get_max_color_value0 module procedure quantum_numbers_get_max_color_value1 module procedure quantum_numbers_get_max_color_value2 end interface <>= pure function quantum_numbers_get_max_color_value0 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value0 pure function quantum_numbers_get_max_color_value1 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), dimension(:), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value1 pure function quantum_numbers_get_max_color_value2 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), dimension(:,:), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value2 @ Inherited from the color component: add an offset to the indices of the color part <>= procedure :: add_color_offset => quantum_numbers_add_color_offset <>= elemental subroutine quantum_numbers_add_color_offset (qn, offset) class(quantum_numbers_t), intent(inout) :: qn integer, intent(in) :: offset call qn%c%add_offset (offset) end subroutine quantum_numbers_add_color_offset @ %def quantum_numbers_add_color_offset @ Given a quantum number array, return all possible color contractions, leaving the other quantum numbers intact. <>= public :: quantum_number_array_make_color_contractions <>= subroutine quantum_number_array_make_color_contractions (qn_in, qn_out) type(quantum_numbers_t), dimension(:), intent(in) :: qn_in type(quantum_numbers_t), dimension(:,:), intent(out), allocatable :: qn_out type(color_t), dimension(:,:), allocatable :: col integer :: i call color_array_make_contractions (qn_in%c, col) allocate (qn_out (size (col, 1), size (col, 2))) do i = 1, size (qn_out, 2) qn_out(:,i)%f = qn_in%f qn_out(:,i)%c = col(:,i) qn_out(:,i)%h = qn_in%h end do end subroutine quantum_number_array_make_color_contractions @ %def quantum_number_array_make_color_contractions @ Inherited from the color component: invert the color, switching particle/antiparticle. <>= procedure :: invert_color => quantum_numbers_invert_color <>= elemental subroutine quantum_numbers_invert_color (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%c%invert () end subroutine quantum_numbers_invert_color @ %def quantum_numbers_invert_color @ Flip helicity. <>= procedure :: flip_helicity => quantum_numbers_flip_helicity <>= elemental subroutine quantum_numbers_flip_helicity (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%h%flip () end subroutine quantum_numbers_flip_helicity @ %def quantum_numbers_flip_helicity @ Merge two quantum number sets: for each entry, if both are defined, combine them to an off-diagonal entry (meaningful only if the input was diagonal). If either entry is undefined, take the defined one. For flavor, off-diagonal entries are invalid, so both flavors must be equal, otherwise an invalid flavor is inserted. <>= public :: operator(.merge.) <>= interface operator(.merge.) module procedure merge_quantum_numbers0 module procedure merge_quantum_numbers1 end interface <>= function merge_quantum_numbers0 (qn1, qn2) result (qn3) type(quantum_numbers_t) :: qn3 type(quantum_numbers_t), intent(in) :: qn1, qn2 qn3%f = qn1%f .merge. qn2%f qn3%c = qn1%c .merge. qn2%c qn3%h = qn1%h .merge. qn2%h qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub) end function merge_quantum_numbers0 function merge_quantum_numbers1 (qn1, qn2) result (qn3) type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2 type(quantum_numbers_t), dimension(size(qn1)) :: qn3 qn3%f = qn1%f .merge. qn2%f qn3%c = qn1%c .merge. qn2%c qn3%h = qn1%h .merge. qn2%h qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub) end function merge_quantum_numbers1 @ %def merge_quantum_numbers @ <>= elemental function merge_subtraction_index (sub1, sub2) result (sub3) integer :: sub3 integer, intent(in) :: sub1, sub2 if (sub1 > 0 .and. sub2 > 0) then if (sub1 == sub2) then sub3 = sub1 else sub3 = 0 end if else if (sub1 > 0) then sub3 = sub1 else if (sub2 > 0) then sub3 = sub2 else sub3 = 0 end if end function merge_subtraction_index @ %def merge_subtraction_index @ \subsection{The quantum number mask} The quantum numbers mask is true for quantum numbers that should be ignored or summed over. The three mandatory entries correspond to flavor, color, and helicity, respectively. There is an additional entry [[cg]]: If false, the color-ghosts property should be kept even if color is ignored. This is relevant only if [[c]] is set, otherwise it is always false. The flag [[hd]] tells that only diagonal entries in helicity should be kept. If [[h]] is set, [[hd]] is irrelevant and will be kept [[.false.]] <>= public :: quantum_numbers_mask_t <>= type :: quantum_numbers_mask_t private logical :: f = .false. logical :: c = .false. logical :: cg = .false. logical :: h = .false. logical :: hd = .false. integer :: sub = 0 contains <> end type quantum_numbers_mask_t @ %def quantum_number_t @ Define a quantum number mask: Constructor form <>= public :: quantum_numbers_mask <>= elemental function quantum_numbers_mask & (mask_f, mask_c, mask_h, mask_cg, mask_hd) result (mask) type(quantum_numbers_mask_t) :: mask logical, intent(in) :: mask_f, mask_c, mask_h logical, intent(in), optional :: mask_cg logical, intent(in), optional :: mask_hd call quantum_numbers_mask_init & (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd) end function quantum_numbers_mask @ %def new_quantum_numbers_mask @ Define quantum numbers: Initializer form <>= procedure :: init => quantum_numbers_mask_init <>= elemental subroutine quantum_numbers_mask_init & (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_f, mask_c, mask_h logical, intent(in), optional :: mask_cg, mask_hd mask%f = mask_f mask%c = mask_c mask%h = mask_h mask%cg = .false. if (present (mask_cg)) then if (mask%c) mask%cg = mask_cg else mask%cg = mask_c end if mask%hd = .false. if (present (mask_hd)) then if (.not. mask%h) mask%hd = mask_hd end if end subroutine quantum_numbers_mask_init @ %def quantum_numbers_mask_init @ Write a quantum numbers mask. We need the stand-alone subroutine for the array case. <>= public :: quantum_numbers_mask_write <>= interface quantum_numbers_mask_write module procedure quantum_numbers_mask_write_single module procedure quantum_numbers_mask_write_array end interface <>= procedure :: write => quantum_numbers_mask_write_single <>= subroutine quantum_numbers_mask_write_single (mask, unit) class(quantum_numbers_mask_t), intent(in) :: mask integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" write (u, "(L1)", advance="no") mask%f write (u, "(L1)", advance="no") mask%c if (.not.mask%cg) write (u, "('g')", advance="no") write (u, "(L1)", advance="no") mask%h if (mask%hd) write (u, "('d')", advance="no") write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_mask_write_single subroutine quantum_numbers_mask_write_array (mask, unit) type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" do i = 1, size (mask) if (i > 1) write (u, "(A)", advance="no") "/" write (u, "(L1)", advance="no") mask(i)%f write (u, "(L1)", advance="no") mask(i)%c if (.not.mask(i)%cg) write (u, "('g')", advance="no") write (u, "(L1)", advance="no") mask(i)%h if (mask(i)%hd) write (u, "('d')", advance="no") end do write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_mask_write_array @ %def quantum_numbers_mask_write @ \subsection{Setting mask components} <>= procedure :: set_flavor => quantum_numbers_mask_set_flavor procedure :: set_color => quantum_numbers_mask_set_color procedure :: set_helicity => quantum_numbers_mask_set_helicity procedure :: set_sub => quantum_numbers_mask_set_sub <>= elemental subroutine quantum_numbers_mask_set_flavor (mask, mask_f) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_f mask%f = mask_f end subroutine quantum_numbers_mask_set_flavor elemental subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_c logical, intent(in), optional :: mask_cg mask%c = mask_c if (present (mask_cg)) then if (mask%c) mask%cg = mask_cg else mask%cg = mask_c end if end subroutine quantum_numbers_mask_set_color elemental subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_h logical, intent(in), optional :: mask_hd mask%h = mask_h if (present (mask_hd)) then if (.not. mask%h) mask%hd = mask_hd end if end subroutine quantum_numbers_mask_set_helicity elemental subroutine quantum_numbers_mask_set_sub (mask, sub) class(quantum_numbers_mask_t), intent(inout) :: mask integer, intent(in) :: sub mask%sub = sub end subroutine quantum_numbers_mask_set_sub @ %def quantum_numbers_mask_set_flavor @ %def quantum_numbers_mask_set_color @ %def quantum_numbers_mask_set_helicity @ %def quantum_numbers_mask_set_sub @ The following routines assign part of a mask, depending on the flags given. <>= procedure :: assign => quantum_numbers_mask_assign <>= elemental subroutine quantum_numbers_mask_assign & (mask, mask_in, flavor, color, helicity) class(quantum_numbers_mask_t), intent(inout) :: mask class(quantum_numbers_mask_t), intent(in) :: mask_in logical, intent(in), optional :: flavor, color, helicity if (present (flavor)) then if (flavor) then mask%f = mask_in%f end if end if if (present (color)) then if (color) then mask%c = mask_in%c mask%cg = mask_in%cg end if end if if (present (helicity)) then if (helicity) then mask%h = mask_in%h mask%hd = mask_in%hd end if end if end subroutine quantum_numbers_mask_assign @ %def quantum_numbers_mask_assign @ \subsection{Mask predicates} Return true if either one of the entries is set: <>= public :: any <>= interface any module procedure quantum_numbers_mask_any end interface <>= function quantum_numbers_mask_any (mask) result (match) logical :: match type(quantum_numbers_mask_t), intent(in) :: mask match = mask%f .or. mask%c .or. mask%h .or. mask%hd end function quantum_numbers_mask_any @ %def any @ \subsection{Operators} The OR operation is applied to all components. <>= generic :: operator(.or.) => quantum_numbers_mask_or procedure, private :: quantum_numbers_mask_or @ %def .or. <>= elemental function quantum_numbers_mask_or (mask1, mask2) result (mask) type(quantum_numbers_mask_t) :: mask class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 mask%f = mask1%f .or. mask2%f mask%c = mask1%c .or. mask2%c if (mask%c) mask%cg = mask1%cg .or. mask2%cg mask%h = mask1%h .or. mask2%h if (.not. mask%h) mask%hd = mask1%hd .or. mask2%hd end function quantum_numbers_mask_or @ %def quantum_numbers_mask_or @ \subsection{Mask comparisons} Return true if the two masks are equivalent / differ: <>= generic :: operator(.eqv.) => quantum_numbers_mask_eqv generic :: operator(.neqv.) => quantum_numbers_mask_neqv procedure, private :: quantum_numbers_mask_eqv procedure, private :: quantum_numbers_mask_neqv <>= elemental function quantum_numbers_mask_eqv (mask1, mask2) result (eqv) logical :: eqv class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 eqv = (mask1%f .eqv. mask2%f) .and. & (mask1%c .eqv. mask2%c) .and. & (mask1%cg .eqv. mask2%cg) .and. & (mask1%h .eqv. mask2%h) .and. & (mask1%hd .eqv. mask2%hd) end function quantum_numbers_mask_eqv elemental function quantum_numbers_mask_neqv (mask1, mask2) result (neqv) logical :: neqv class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 neqv = (mask1%f .neqv. mask2%f) .or. & (mask1%c .neqv. mask2%c) .or. & (mask1%cg .neqv. mask2%cg) .or. & (mask1%h .neqv. mask2%h) .or. & (mask1%hd .neqv. mask2%hd) end function quantum_numbers_mask_neqv @ %def .eqv. .neqv. @ \subsection{Apply a mask} Applying a mask to the quantum number object means undefining those entries where the mask is set. The others remain unaffected. The [[hd]] mask has the special property that it ``diagonalizes'' helicity, i.e., the second helicity entry is dropped and the result is a diagonal helicity quantum number. <>= procedure :: undefine => quantum_numbers_undefine procedure :: undefined => quantum_numbers_undefined0 <>= public :: quantum_numbers_undefined <>= interface quantum_numbers_undefined module procedure quantum_numbers_undefined0 module procedure quantum_numbers_undefined1 module procedure quantum_numbers_undefined11 end interface <>= elemental subroutine quantum_numbers_undefine (qn, mask) class(quantum_numbers_t), intent(inout) :: qn type(quantum_numbers_mask_t), intent(in) :: mask if (mask%f) call qn%f%undefine () if (mask%c) call qn%c%undefine (undefine_ghost = mask%cg) if (mask%h) then call qn%h%undefine () else if (mask%hd) then if (.not. qn%h%is_diagonal ()) then call qn%h%diagonalize () end if end if if (mask%sub > 0) qn%sub = 0 end subroutine quantum_numbers_undefine function quantum_numbers_undefined0 (qn, mask) result (qn_new) class(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_t) :: qn_new select type (qn) type is (quantum_numbers_t); qn_new = qn end select call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined0 function quantum_numbers_undefined1 (qn, mask) result (qn_new) type(quantum_numbers_t), dimension(:), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_t), dimension(size(qn)) :: qn_new qn_new = qn call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined1 function quantum_numbers_undefined11 (qn, mask) result (qn_new) type(quantum_numbers_t), dimension(:), intent(in) :: qn type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(quantum_numbers_t), dimension(size(qn)) :: qn_new qn_new = qn call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined11 @ %def quantum_numbers_undefine @ %def quantum_numbers_undefined @ Return true if the input quantum number set has entries that would be removed by the applied mask, e.g., if polarization is defined but [[mask%h]] is set: <>= procedure :: are_redundant => quantum_numbers_are_redundant <>= elemental function quantum_numbers_are_redundant (qn, mask) & result (redundant) logical :: redundant class(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask redundant = .false. if (mask%f) then redundant = qn%f%is_defined () end if if (mask%c) then redundant = qn%c%is_defined () end if if (mask%h) then redundant = qn%h%is_defined () else if (mask%hd) then redundant = .not. qn%h%is_diagonal () end if if (mask%sub > 0) redundant = qn%sub >= mask%sub end function quantum_numbers_are_redundant @ %def quantum_numbers_are_redundant @ Return true if the helicity flag is set or the diagonal-helicity flag is set. <>= procedure :: diagonal_helicity => quantum_numbers_mask_diagonal_helicity <>= elemental function quantum_numbers_mask_diagonal_helicity (mask) & result (flag) logical :: flag class(quantum_numbers_mask_t), intent(in) :: mask flag = mask%h .or. mask%hd end function quantum_numbers_mask_diagonal_helicity @ %def quantum_numbers_mask_diagonal_helicity @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Transition Matrices and Evaluation} The modules in this chapter implement transition matrices and calculations. The functionality is broken down in three modules \begin{description} \item[state\_matrices] represent state and transition density matrices built from particle quantum numbers (helicity, color, flavor) \item[interactions] extend state matrices with the record of particle momenta. They also distinguish in- and out-particles and store parent-child relations. \item[evaluators] These objects extend interaction objects by the information how to calculate matrix elements from products and squares of other interactions. They implement the methods to actually compute those matrix elements. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{State matrices} This module deals with the internal state of a particle system, i.e., with its density matrix in flavor, color, and helicity space. <<[[state_matrices.f90]]>>= <> module state_matrices <> use io_units use format_utils, only: pac_fmt use format_defs, only: FMT_17, FMT_19 use diagnostics use sorting use model_data use flavors use colors use helicities use quantum_numbers <> <> <> <> <> contains <> end module state_matrices @ %def state_matrices @ \subsection{Nodes of the quantum state trie} A quantum state object represents an unnormalized density matrix, i.e., an array of possibilities for flavor, color, and helicity indices with associated complex values. Physically, the trace of this matrix is the summed squared matrix element for an interaction, and the matrix elements divided by this value correspond to the flavor-color-helicity density matrix. (Flavor and color are diagonal.) We store density matrices as tries, that is, as trees where each branching represents the possible quantum numbers of a particle. The first branching is the first particle in the system. A leaf (the node corresponding to the last particle) contains the value of the matrix element. Each node contains a flavor, color, and helicity entry. Note that each of those entries may be actually undefined, so we can also represent, e.g., unpolarized particles. The value is meaningful only for leaves, which have no child nodes. There is a pointer to the parent node which allows for following the trie downwards from a leaf, it is null for a root node. The child nodes are implemented as a list, so there is a pointer to the first and last child, and each node also has a [[next]] pointer to the next sibling. The root node does not correspond to a particle, only its children do. The quantum numbers of the root node are irrelevant and will not be set. However, we use a common type for the three classes (root, branch, leaf); they may easily be distinguished by the association status of parent and child. \subsubsection{Node type} The node is linked in all directions: the parent, the first and last in the list of children, and the previous and next sibling. This allows us for adding and removing nodes and whole branches anywhere in the trie. (Circular links are not allowed, however.). The node holds its associated set of quantum numbers. The integer index, which is set only for leaf nodes, is the index of the corresponding matrix element value within the state matrix. Temporarily, matrix-element values may be stored within a leaf node. This is used during state-matrix factorization. When the state matrix is [[freeze]]d, these values are transferred to the matrix-element array within the host state matrix. <>= type :: node_t private type(quantum_numbers_t) :: qn type(node_t), pointer :: parent => null () type(node_t), pointer :: child_first => null () type(node_t), pointer :: child_last => null () type(node_t), pointer :: next => null () type(node_t), pointer :: previous => null () integer :: me_index = 0 integer, dimension(:), allocatable :: me_count complex(default) :: me = 0 end type node_t @ %def node_t @ \subsubsection{Operations on nodes} Recursively deallocate all children of the current node. This includes any values associated with the children. <>= pure recursive subroutine node_delete_offspring (node) type(node_t), pointer :: node type(node_t), pointer :: child child => node%child_first do while (associated (child)) node%child_first => node%child_first%next call node_delete_offspring (child) deallocate (child) child => node%child_first end do node%child_last => null () end subroutine node_delete_offspring @ %def node_delete_offspring @ Remove a node including its offspring. Adjust the pointers of parent and siblings, if necessary. <>= pure subroutine node_delete (node) type(node_t), pointer :: node call node_delete_offspring (node) if (associated (node%previous)) then node%previous%next => node%next else if (associated (node%parent)) then node%parent%child_first => node%next end if if (associated (node%next)) then node%next%previous => node%previous else if (associated (node%parent)) then node%parent%child_last => node%previous end if deallocate (node) end subroutine node_delete @ %def node_delete @ Append a child node <>= subroutine node_append_child (node, child) type(node_t), target, intent(inout) :: node type(node_t), pointer :: child allocate (child) if (associated (node%child_last)) then node%child_last%next => child child%previous => node%child_last else node%child_first => child end if node%child_last => child child%parent => node end subroutine node_append_child @ %def node_append_child @ \subsubsection{I/O} Output of a single node, no recursion. We print the quantum numbers in square brackets, then the value (if any). <>= subroutine node_write (node, me_array, verbose, unit, col_verbose, testflag) type(node_t), intent(in) :: node complex(default), dimension(:), intent(in), optional :: me_array logical, intent(in), optional :: verbose, col_verbose, testflag integer, intent(in), optional :: unit logical :: verb integer :: u character(len=7) :: fmt call pac_fmt (fmt, FMT_19, FMT_17, testflag) verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit); if (u < 0) return call node%qn%write (u, col_verbose) if (node%me_index /= 0) then write (u, "(A,I0,A)", advance="no") " => ME(", node%me_index, ")" if (present (me_array)) then write (u, "(A)", advance="no") " = " write (u, "('('," // fmt // ",','," // fmt // ",')')", & advance="no") pacify_complex (me_array(node%me_index)) end if end if write (u, *) if (verb) then call ptr_write ("parent ", node%parent) call ptr_write ("child_first", node%child_first) call ptr_write ("child_last ", node%child_last) call ptr_write ("next ", node%next) call ptr_write ("previous ", node%previous) end if contains subroutine ptr_write (label, node) character(*), intent(in) :: label type(node_t), pointer :: node if (associated (node)) then write (u, "(10x,A,1x,'->',1x)", advance="no") label call node%qn%write (u, col_verbose) write (u, *) end if end subroutine ptr_write end subroutine node_write @ %def node_write @ Recursive output of a node: <>= recursive subroutine node_write_rec (node, me_array, verbose, & indent, unit, col_verbose, testflag) type(node_t), intent(in), target :: node complex(default), dimension(:), intent(in), optional :: me_array logical, intent(in), optional :: verbose, col_verbose, testflag integer, intent(in), optional :: indent integer, intent(in), optional :: unit type(node_t), pointer :: current logical :: verb integer :: i, u verb = .false.; if (present (verbose)) verb = verbose i = 0; if (present (indent)) i = indent u = given_output_unit (unit); if (u < 0) return current => node%child_first do while (associated (current)) write (u, "(A)", advance="no") repeat (" ", i) call node_write (current, me_array, verbose = verb, & unit = u, col_verbose = col_verbose, testflag = testflag) call node_write_rec (current, me_array, verbose = verb, & indent = i + 2, unit = u, col_verbose = col_verbose, testflag = testflag) current => current%next end do end subroutine node_write_rec @ %def node_write_rec @ Binary I/O. Matrix elements are written only for leaf nodes. <>= recursive subroutine node_write_raw_rec (node, u) type(node_t), intent(in), target :: node integer, intent(in) :: u logical :: associated_child_first, associated_next call node%qn%write_raw (u) associated_child_first = associated (node%child_first) write (u) associated_child_first associated_next = associated (node%next) write (u) associated_next if (associated_child_first) then call node_write_raw_rec (node%child_first, u) else write (u) node%me_index write (u) node%me end if if (associated_next) then call node_write_raw_rec (node%next, u) end if end subroutine node_write_raw_rec recursive subroutine node_read_raw_rec (node, u, parent, iostat) type(node_t), intent(out), target :: node integer, intent(in) :: u type(node_t), intent(in), optional, target :: parent integer, intent(out), optional :: iostat logical :: associated_child_first, associated_next type(node_t), pointer :: child call node%qn%read_raw (u, iostat=iostat) read (u, iostat=iostat) associated_child_first read (u, iostat=iostat) associated_next if (present (parent)) node%parent => parent if (associated_child_first) then allocate (child) node%child_first => child node%child_last => null () call node_read_raw_rec (child, u, node, iostat=iostat) do while (associated (child)) child%previous => node%child_last node%child_last => child child => child%next end do else read (u, iostat=iostat) node%me_index read (u, iostat=iostat) node%me end if if (associated_next) then allocate (node%next) call node_read_raw_rec (node%next, u, parent, iostat=iostat) end if end subroutine node_read_raw_rec @ %def node_write_raw @ \subsection{State matrix} \subsubsection{Definition} The quantum state object is a container that keeps and hides the root node. For direct accessibility of values, they are stored in a separate array. The leaf nodes of the quantum-number tree point to those values, once the state matrix is finalized. The [[norm]] component is redefined if a common factor is extracted from all nodes. <>= public :: state_matrix_t <>= type :: state_matrix_t private type(node_t), pointer :: root => null () integer :: depth = 0 integer :: n_matrix_elements = 0 logical :: leaf_nodes_store_values = .false. integer :: n_counters = 0 complex(default), dimension(:), allocatable :: me real(default) :: norm = 1 integer :: n_sub = -1 contains <> end type state_matrix_t @ %def state_matrix_t @ This initializer allocates the root node but does not fill anything. We declare whether values are stored within the nodes during state-matrix construction, and how many counters should be maintained (default: none). <>= procedure :: init => state_matrix_init <>= subroutine state_matrix_init (state, store_values, n_counters) class(state_matrix_t), intent(out) :: state logical, intent(in), optional :: store_values integer, intent(in), optional :: n_counters allocate (state%root) if (present (store_values)) & state%leaf_nodes_store_values = store_values if (present (n_counters)) state%n_counters = n_counters end subroutine state_matrix_init @ %def state_matrix_init @ This recursively deletes all children of the root node, restoring the initial state. The matrix element array is not finalized, since it does not contain physical entries, just pointers. <>= procedure :: final => state_matrix_final <>= subroutine state_matrix_final (state) class(state_matrix_t), intent(inout) :: state if (allocated (state%me)) deallocate (state%me) if (associated (state%root)) call node_delete (state%root) state%depth = 0 state%n_matrix_elements = 0 end subroutine state_matrix_final @ %def state_matrix_final @ Output: Present the tree as a nested list with appropriate indentation. <>= procedure :: write => state_matrix_write <>= subroutine state_matrix_write (state, unit, write_value_list, & verbose, col_verbose, testflag) class(state_matrix_t), intent(in) :: state logical, intent(in), optional :: write_value_list, verbose, col_verbose logical, intent(in), optional :: testflag integer, intent(in), optional :: unit complex(default) :: me_dum character(len=7) :: fmt integer :: u integer :: i call pac_fmt (fmt, FMT_19, FMT_17, testflag) u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A," // fmt // ")") "State matrix: norm = ", state%norm if (associated (state%root)) then if (allocated (state%me)) then call node_write_rec (state%root, state%me, verbose = verbose, & indent = 1, unit = u, col_verbose = col_verbose, & testflag = testflag) else call node_write_rec (state%root, verbose = verbose, indent = 1, & unit = u, col_verbose = col_verbose, testflag = testflag) end if end if if (present (write_value_list)) then if (write_value_list .and. allocated (state%me)) then do i = 1, size (state%me) write (u, "(1x,I0,A)", advance="no") i, ":" me_dum = state%me(i) if (real(state%me(i)) == -real(state%me(i))) then me_dum = & cmplx (0._default, aimag(me_dum), kind=default) end if if (aimag(me_dum) == -aimag(me_dum)) then me_dum = & cmplx (real(me_dum), 0._default, kind=default) end if write (u, "('('," // fmt // ",','," // fmt // & ",')')") me_dum end do end if end if end subroutine state_matrix_write @ %def state_matrix_write @ Binary I/O. The auxiliary matrix-element array is not written, but reconstructed after reading the tree. Note: To be checked. Might be broken, don't use (unless trivial). <>= procedure :: write_raw => state_matrix_write_raw procedure :: read_raw => state_matrix_read_raw <>= subroutine state_matrix_write_raw (state, u) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: u logical :: is_defined integer :: depth, j type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn is_defined = state%is_defined () write (u) is_defined if (is_defined) then write (u) state%get_norm () write (u) state%get_n_leaves () depth = state%get_depth () write (u) depth allocate (qn (depth)) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () do j = 1, depth call qn(j)%write_raw (u) end do write (u) it%get_me_index () write (u) it%get_matrix_element () call it%advance () end do end if end subroutine state_matrix_write_raw subroutine state_matrix_read_raw (state, u, iostat) class(state_matrix_t), intent(out) :: state integer, intent(in) :: u integer, intent(out) :: iostat logical :: is_defined real(default) :: norm integer :: n_leaves, depth, i, j type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: me_index complex(default) :: me read (u, iostat=iostat) is_defined if (iostat /= 0) goto 1 if (is_defined) then call state%init (store_values = .true.) read (u, iostat=iostat) norm if (iostat /= 0) goto 1 call state_matrix_set_norm (state, norm) read (u) n_leaves if (iostat /= 0) goto 1 read (u) depth if (iostat /= 0) goto 1 allocate (qn (depth)) do i = 1, n_leaves do j = 1, depth call qn(j)%read_raw (u, iostat=iostat) if (iostat /= 0) goto 1 end do read (u, iostat=iostat) me_index if (iostat /= 0) goto 1 read (u, iostat=iostat) me if (iostat /= 0) goto 1 call state%add_state (qn, index = me_index, value = me) end do call state_matrix_freeze (state) end if return ! Clean up on error 1 continue call state%final () end subroutine state_matrix_read_raw @ %def state_matrix_write_raw state_matrix_read_raw @ Assign a model pointer to all flavor entries. This will become necessary when we have read a state matrix from file. <>= procedure :: set_model => state_matrix_set_model <>= subroutine state_matrix_set_model (state, model) class(state_matrix_t), intent(inout), target :: state class(model_data_t), intent(in), target :: model type(state_iterator_t) :: it call it%init (state) do while (it%is_valid ()) call it%set_model (model) call it%advance () end do end subroutine state_matrix_set_model @ %def state_matrix_set_model @ Iterate over [[state]], get the quantum numbers array [[qn]] for each iteration, and tag all array elements of [[qn]] with the indizes given by [[tag]] as part of the hard interaction. Then add them to [[tagged_state]] and return it. If no [[tag]] is given, tag all [[qn]] as part of the hard process. <>= procedure :: tag_hard_process => state_matrix_tag_hard_process <>= subroutine state_matrix_tag_hard_process (state, tagged_state, tag) class(state_matrix_t), intent(in), target :: state type(state_matrix_t), intent(out) :: tagged_state integer, dimension(:), intent(in), optional :: tag type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn complex(default) :: value integer :: i call tagged_state%init (store_values = .true.) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () value = it%get_matrix_element () if (present (tag)) then do i = 1, size (tag) call qn(tag(i))%tag_hard_process () end do else call qn%tag_hard_process () end if call tagged_state%add_state (qn, index = it%get_me_index (), value = value) call it%advance () end do call tagged_state%freeze () end subroutine state_matrix_tag_hard_process @ %def state_matrix_tag_hard_process \subsubsection{Properties of the quantum state} A state is defined if its root is allocated: <>= procedure :: is_defined => state_matrix_is_defined <>= elemental function state_matrix_is_defined (state) result (defined) logical :: defined class(state_matrix_t), intent(in) :: state defined = associated (state%root) end function state_matrix_is_defined @ %def state_matrix_is_defined @ A state is empty if its depth is zero: <>= procedure :: is_empty => state_matrix_is_empty <>= elemental function state_matrix_is_empty (state) result (flag) logical :: flag class(state_matrix_t), intent(in) :: state flag = state%depth == 0 end function state_matrix_is_empty @ %def state_matrix_is_empty @ Return the number of matrix-element values. <>= generic :: get_n_matrix_elements => get_n_matrix_elements_all, get_n_matrix_elements_mask procedure :: get_n_matrix_elements_all => state_matrix_get_n_matrix_elements_all procedure :: get_n_matrix_elements_mask => state_matrix_get_n_matrix_elements_mask <>= pure function state_matrix_get_n_matrix_elements_all (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state n = state%n_matrix_elements end function state_matrix_get_n_matrix_elements_all @ %def state_matrix_get_n_matrix_elements_all @ <>= function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n) integer :: n class(state_matrix_t), intent(in) :: state type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask type(state_iterator_t) :: it type(quantum_numbers_t), dimension(size(qn_mask)) :: qn type(state_matrix_t) :: state_tmp call state_tmp%init () call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%undefine (qn_mask) call state_tmp%add_state (qn) call it%advance () end do n = state_tmp%n_matrix_elements call state_tmp%final () end function state_matrix_get_n_matrix_elements_mask @ %def state_matrix_get_n_matrix_elments_mask @ Return the size of the [[me]]-array for debugging purposes. <>= procedure :: get_me_size => state_matrix_get_me_size <>= pure function state_matrix_get_me_size (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state if (allocated (state%me)) then n = size (state%me) else n = 0 end if end function state_matrix_get_me_size @ %def state_matrix_get_me_size @ <>= procedure :: compute_n_sub => state_matrix_compute_n_sub <>= function state_matrix_compute_n_sub (state) result (n_sub) integer :: n_sub class(state_matrix_t), intent(in) :: state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(state%depth) :: qn integer :: sub, sub_pos n_sub = 0 call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () sub = 0 sub_pos = qn_array_sub_pos () if (sub_pos > 0) sub = qn(sub_pos)%get_sub () if (sub > n_sub) n_sub = sub call it%advance () end do contains function qn_array_sub_pos () result (pos) integer :: pos integer :: i pos = 0 do i = 1, state%depth if (qn(i)%get_sub () > 0) then pos = i exit end if end do end function qn_array_sub_pos end function state_matrix_compute_n_sub @ %def state_matrix_compute_n_sub @ <>= procedure :: set_n_sub => state_matrix_set_n_sub <>= subroutine state_matrix_set_n_sub (state) class(state_matrix_t), intent(inout) :: state state%n_sub = state%compute_n_sub () end subroutine state_matrix_set_n_sub @ %def state_matrix_set_n_sub @ Return number of subtractions. <>= procedure :: get_n_sub => state_matrix_get_n_sub <>= function state_matrix_get_n_sub (state) result (n_sub) integer :: n_sub class(state_matrix_t), intent(in) :: state if (state%n_sub < 0) then call msg_bug ("[state_matrix_get_n_sub] number of subtractions not set.") end if n_sub = state%n_sub end function state_matrix_get_n_sub @ %def state_matrix_get_n_sub @ Return the number of leaves. This can be larger than the number of independent matrix elements. <>= procedure :: get_n_leaves => state_matrix_get_n_leaves <>= function state_matrix_get_n_leaves (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state type(state_iterator_t) :: it n = 0 call it%init (state) do while (it%is_valid ()) n = n + 1 call it%advance () end do end function state_matrix_get_n_leaves @ %def state_matrix_get_n_leaves @ Return the depth: <>= procedure :: get_depth => state_matrix_get_depth <>= pure function state_matrix_get_depth (state) result (depth) integer :: depth class(state_matrix_t), intent(in) :: state depth = state%depth end function state_matrix_get_depth @ %def state_matrix_get_depth @ Return the norm: <>= procedure :: get_norm => state_matrix_get_norm <>= pure function state_matrix_get_norm (state) result (norm) real(default) :: norm class(state_matrix_t), intent(in) :: state norm = state%norm end function state_matrix_get_norm @ %def state_matrix_get_norm @ \subsubsection{Retrieving contents} Return the quantum number array, using an index. We have to scan the state matrix since there is no shortcut. <>= procedure :: get_quantum_number => & state_matrix_get_quantum_number <>= function state_matrix_get_quantum_number (state, i, by_me_index) result (qn) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: i logical, intent(in), optional :: by_me_index logical :: opt_by_me_index type(quantum_numbers_t), dimension(state%depth) :: qn type(state_iterator_t) :: it integer :: k opt_by_me_index = .false. if (present (by_me_index)) opt_by_me_index = by_me_index k = 0 call it%init (state) do while (it%is_valid ()) if (opt_by_me_index) then k = it%get_me_index () else k = k + 1 end if if (k == i) then qn = it%get_quantum_numbers () exit end if call it%advance () end do end function state_matrix_get_quantum_number @ %def state_matrix_get_quantum_number <>= generic :: get_quantum_numbers => get_quantum_numbers_all, get_quantum_numbers_mask procedure :: get_quantum_numbers_all => state_matrix_get_quantum_numbers_all procedure :: get_quantum_numbers_mask => state_matrix_get_quantum_numbers_mask <>= subroutine state_matrix_get_quantum_numbers_all (state, qn) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn integer :: i allocate (qn (state%get_n_matrix_elements (), & state%get_depth())) do i = 1, state%get_n_matrix_elements () qn (i, :) = state%get_quantum_number (i) end do end subroutine state_matrix_get_quantum_numbers_all @ %def state_matrix_get_quantum_numbers_all @ <>= subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn type(quantum_numbers_t), dimension(:), allocatable :: qn_tmp type(state_matrix_t) :: state_tmp type(state_iterator_t) :: it integer :: i, n n = state%get_n_matrix_elements (qn_mask) allocate (qn (n, state%get_depth ())) allocate (qn_tmp (state%get_depth ())) call it%init (state) call state_tmp%init () do while (it%is_valid ()) qn_tmp = it%get_quantum_numbers () call qn_tmp%undefine (qn_mask) call state_tmp%add_state (qn_tmp) call it%advance () end do do i = 1, n qn (i, :) = state_tmp%get_quantum_number (i) end do call state_tmp%final () end subroutine state_matrix_get_quantum_numbers_mask @ %def state_matrix_get_quantum_numbers_mask @ <>= procedure :: get_flavors => state_matrix_get_flavors <>= subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv) class(state_matrix_t), intent(in), target :: state logical, intent(in) :: only_elementary type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask integer, intent(out), dimension(:,:), allocatable :: flv type(quantum_numbers_t), dimension(:,:), allocatable :: qn integer :: i_flv, n_partons type(flavor_t), dimension(:), allocatable :: flv_flv if (present (qn_mask)) then call state%get_quantum_numbers (qn_mask, qn) else call state%get_quantum_numbers (qn) end if allocate (flv_flv (size (qn, dim=2))) if (only_elementary) then flv_flv = qn(1, :)%get_flavor () n_partons = count (is_elementary (flv_flv%get_pdg ())) end if allocate (flv (n_partons, size (qn, dim=1))) associate (n_flv => size (qn, dim=1)) do i_flv = 1, size (qn, dim=1) flv_flv = qn(i_flv, :)%get_flavor () flv(:, i_flv) = pack (flv_flv%get_pdg (), is_elementary(flv_flv%get_pdg())) end do end associate contains elemental function is_elementary (pdg) logical :: is_elementary integer, intent(in) :: pdg is_elementary = abs(pdg) /= 2212 .and. abs(pdg) /= 92 .and. abs(pdg) /= 93 end function is_elementary end subroutine state_matrix_get_flavors @ %def state_matrix_get_flavors @ Return a single matrix element using its index. Works only if the shortcut array is allocated. <>= generic :: get_matrix_element => get_matrix_element_single generic :: get_matrix_element => get_matrix_element_array procedure :: get_matrix_element_single => & state_matrix_get_matrix_element_single procedure :: get_matrix_element_array => & state_matrix_get_matrix_element_array <>= elemental function state_matrix_get_matrix_element_single (state, i) result (me) complex(default) :: me class(state_matrix_t), intent(in) :: state integer, intent(in) :: i if (allocated (state%me)) then me = state%me(i) else me = 0 end if end function state_matrix_get_matrix_element_single @ %def state_matrix_get_matrix_element_single @ <>= function state_matrix_get_matrix_element_array (state) result (me) complex(default), dimension(:), allocatable :: me class(state_matrix_t), intent(in) :: state if (allocated (state%me)) then allocate (me (size (state%me))) me = state%me else me = 0 end if end function state_matrix_get_matrix_element_array @ %def state_matrix_get_matrix_element_array @ Return the color index with maximum absolute value that is present within the state matrix. <>= procedure :: get_max_color_value => state_matrix_get_max_color_value <>= function state_matrix_get_max_color_value (state) result (cmax) integer :: cmax class(state_matrix_t), intent(in) :: state if (associated (state%root)) then cmax = node_get_max_color_value (state%root) else cmax = 0 end if contains recursive function node_get_max_color_value (node) result (cmax) integer :: cmax type(node_t), intent(in), target :: node type(node_t), pointer :: current cmax = quantum_numbers_get_max_color_value (node%qn) current => node%child_first do while (associated (current)) cmax = max (cmax, node_get_max_color_value (current)) current => current%next end do end function node_get_max_color_value end function state_matrix_get_max_color_value @ %def state_matrix_get_max_color_value @ \subsubsection{Building the quantum state} The procedure generates a branch associated to the input array of quantum numbers. If the branch exists already, it is used. Optionally, we set the matrix-element index, a value (which may be added to the previous one), and increment one of the possible counters. We may also return the matrix element index of the current node. <>= procedure :: add_state => state_matrix_add_state <>= subroutine state_matrix_add_state (state, qn, index, value, & sum_values, counter_index, ignore_sub, me_index) class(state_matrix_t), intent(inout) :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: index complex(default), intent(in), optional :: value logical, intent(in), optional :: sum_values integer, intent(in), optional :: counter_index logical, intent(in), optional :: ignore_sub integer, intent(out), optional :: me_index logical :: set_index, get_index, add set_index = present (index) get_index = present (me_index) add = .false.; if (present (sum_values)) add = sum_values if (state%depth == 0) then state%depth = size (qn) else if (state%depth /= size (qn)) then call state%write () call msg_bug ("State matrix: depth mismatch") end if if (size (qn) > 0) call node_make_branch (state%root, qn) contains recursive subroutine node_make_branch (parent, qn) type(node_t), pointer :: parent type(quantum_numbers_t), dimension(:), intent(in) :: qn type(node_t), pointer :: child logical :: match match = .false. child => parent%child_first SCAN_CHILDREN: do while (associated (child)) if (present (ignore_sub)) then if (ignore_sub) then match = quantum_numbers_eq_wo_sub (child%qn, qn(1)) else match = child%qn == qn(1) end if else match = child%qn == qn(1) end if if (match) exit SCAN_CHILDREN child => child%next end do SCAN_CHILDREN if (.not. match) then call node_append_child (parent, child) child%qn = qn(1) end if select case (size (qn)) case (1) if (.not. match) then state%n_matrix_elements = state%n_matrix_elements + 1 child%me_index = state%n_matrix_elements end if if (set_index) then child%me_index = index end if if (get_index) then me_index = child%me_index end if if (present (counter_index)) then if (.not. allocated (child%me_count)) then allocate (child%me_count (state%n_counters)) child%me_count = 0 end if child%me_count(counter_index) = child%me_count(counter_index) + 1 end if if (present (value)) then if (add) then child%me = child%me + value else child%me = value end if end if case (2:) call node_make_branch (child, qn(2:)) end select end subroutine node_make_branch end subroutine state_matrix_add_state @ %def state_matrix_add_state @ Remove irrelevant flavor/color/helicity labels and the corresponding branchings. The masks indicate which particles are affected; the masks length should coincide with the depth of the trie (without the root node). Recursively scan the whole tree, starting from the leaf nodes and working up to the root node. If a mask entry is set for the current tree level, scan the children there. For each child within that level make a new empty branch where the masked quantum number is undefined. Then recursively combine all following children with matching quantum number into this new node and move on. <>= procedure :: collapse => state_matrix_collapse <>= subroutine state_matrix_collapse (state, mask) class(state_matrix_t), intent(inout) :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(state_matrix_t) :: red_state if (state%is_defined ()) then call state%reduce (mask, red_state) call state%final () state = red_state end if end subroutine state_matrix_collapse @ %def state_matrix_collapse @ Transform the given state matrix into a reduced state matrix where some quantum numbers are removed, as indicated by the mask. The procedure creates a new state matrix, so the old one can be deleted after this if it is no longer used. It is said that the matrix element ordering is lost afterwards. We allow to keep the original matrix element index in the new state matrix. If the matrix element indices are kept, we do not freeze the state matrix. After reordering the matrix element indices by [[state_matrix_reorder_me]], the state matrix can be frozen. <>= procedure :: reduce => state_matrix_reduce <>= subroutine state_matrix_reduce (state, mask, red_state, keep_me_index) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(state_matrix_t), intent(out) :: red_state logical, optional, intent(in) :: keep_me_index logical :: opt_keep_me_index type(state_iterator_t) :: it type(quantum_numbers_t), dimension(size(mask)) :: qn opt_keep_me_index = .false. if (present (keep_me_index)) opt_keep_me_index = keep_me_index call red_state%init () call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%undefine (mask) if (opt_keep_me_index) then call red_state%add_state (qn, index = it%get_me_index ()) else call red_state%add_state (qn) end if call it%advance () end do if (.not. opt_keep_me_index) then call red_state%freeze () end if end subroutine state_matrix_reduce @ %def state_matrix_reduce @ Reorder the matrix elements -- not the tree itself. The procedure is necessary in case the matrix element indices were kept when reducing over quantum numbers and one wants to reintroduce the previous order of the matrix elements. <>= procedure :: reorder_me => state_matrix_reorder_me <>= subroutine state_matrix_reorder_me (state, ordered_state) class(state_matrix_t), intent(in), target :: state type(state_matrix_t), intent(out) :: ordered_state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(state%depth) :: qn integer, dimension(:), allocatable :: me_index integer :: i call ordered_state%init () call get_me_index_sorted (state, me_index) i = 1; call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call ordered_state%add_state (qn, index = me_index(i)) i = i + 1; call it%advance () end do call ordered_state%freeze () contains subroutine get_me_index_sorted (state, me_index) class(state_matrix_t), intent(in), target :: state integer, dimension(:), allocatable, intent(out) :: me_index type(state_iterator_t) :: it integer :: i, j integer, dimension(:), allocatable :: me_index_unsorted, me_index_sorted associate (n_matrix_elements => state%get_n_matrix_elements ()) allocate (me_index(n_matrix_elements), source = 0) allocate (me_index_sorted(n_matrix_elements), source = 0) allocate (me_index_unsorted(n_matrix_elements), source = 0) i = 1; call it%init (state) do while (it%is_valid ()) me_index_unsorted(i) = it%get_me_index () i = i + 1 call it%advance () end do me_index_sorted = sort (me_index_unsorted) ! We do not care about efficiency at this point. UNSORTED: do i = 1, n_matrix_elements SORTED: do j = 1, n_matrix_elements if (me_index_unsorted(i) == me_index_sorted(j)) then me_index(i) = j cycle UNSORTED end if end do SORTED end do UNSORTED end associate end subroutine get_me_index_sorted end subroutine state_matrix_reorder_me @ %def state_matrix_order_by_flavors @ This subroutine sets up the matrix-element array. The leaf nodes aquire the index values that point to the appropriate matrix-element entry. We recursively scan the trie. Once we arrive at a leaf node, the index is increased and associated to that node. Finally, we allocate the matrix-element array with the appropriate size. If matrix element values are temporarily stored within the leaf nodes, we scan the state again and transfer them to the matrix-element array. <>= procedure :: freeze => state_matrix_freeze <>= subroutine state_matrix_freeze (state) class(state_matrix_t), intent(inout), target :: state type(state_iterator_t) :: it if (associated (state%root)) then if (allocated (state%me)) deallocate (state%me) allocate (state%me (state%n_matrix_elements)) state%me = 0 call state%set_n_sub () end if if (state%leaf_nodes_store_values) then call it%init (state) do while (it%is_valid ()) state%me(it%get_me_index ()) = it%get_matrix_element () call it%advance () end do state%leaf_nodes_store_values = .false. end if end subroutine state_matrix_freeze @ %def state_matrix_freeze @ \subsubsection{Direct access to the value array} Several methods for setting a value directly are summarized in this generic: <>= generic :: set_matrix_element => set_matrix_element_qn generic :: set_matrix_element => set_matrix_element_all generic :: set_matrix_element => set_matrix_element_array generic :: set_matrix_element => set_matrix_element_single generic :: set_matrix_element => set_matrix_element_clone procedure :: set_matrix_element_qn => state_matrix_set_matrix_element_qn procedure :: set_matrix_element_all => state_matrix_set_matrix_element_all procedure :: set_matrix_element_array => & state_matrix_set_matrix_element_array procedure :: set_matrix_element_single => & state_matrix_set_matrix_element_single procedure :: set_matrix_element_clone => & state_matrix_set_matrix_element_clone @ %def state_matrix_set_matrix_element @ Set a value that corresponds to a quantum number array: <>= subroutine state_matrix_set_matrix_element_qn (state, qn, value) class(state_matrix_t), intent(inout), target :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value type(state_iterator_t) :: it if (.not. allocated (state%me)) then allocate (state%me (size(qn))) end if call it%init (state) call it%go_to_qn (qn) call it%set_matrix_element (value) end subroutine state_matrix_set_matrix_element_qn @ %def state_matrix_set_matrix_element_qn @ Set all matrix elements to a single value <>= subroutine state_matrix_set_matrix_element_all (state, value) class(state_matrix_t), intent(inout) :: state complex(default), intent(in) :: value if (.not. allocated (state%me)) then allocate (state%me (state%n_matrix_elements)) end if state%me = value end subroutine state_matrix_set_matrix_element_all @ %def state_matrix_set_matrix_element_all @ Set the matrix-element array directly. <>= subroutine state_matrix_set_matrix_element_array (state, value, range) class(state_matrix_t), intent(inout) :: state complex(default), intent(in), dimension(:) :: value integer, intent(in), dimension(:), optional :: range integer :: i, n_me, n_val, i_first, i_last if (present (range)) then state%me(range) = value else if (.not. allocated (state%me)) & allocate (state%me (size (value))) state%me(:) = value end if end subroutine state_matrix_set_matrix_element_array pure subroutine state_matrix_set_matrix_element_single (state, i, value) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i complex(default), intent(in) :: value if (.not. allocated (state%me)) then allocate (state%me (state%n_matrix_elements)) end if state%me(i) = value end subroutine state_matrix_set_matrix_element_single @ %def state_matrix_set_matrix_element_array @ %def state_matrix_set_matrix_element_single @ Clone the matrix elements from another (matching) state matrix. <>= subroutine state_matrix_set_matrix_element_clone (state, state1) class(state_matrix_t), intent(inout) :: state type(state_matrix_t), intent(in) :: state1 if (.not. allocated (state1%me)) return if (.not. allocated (state%me)) allocate (state%me (size (state1%me))) state%me = state1%me end subroutine state_matrix_set_matrix_element_clone @ %def state_matrix_set_matrix_element_clone @ Add a value to a matrix element <>= procedure :: add_to_matrix_element => state_matrix_add_to_matrix_element <>= subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor) class(state_matrix_t), intent(inout), target :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value logical, intent(in), optional :: match_only_flavor type(state_iterator_t) :: it call it%init (state) call it%go_to_qn (qn, match_only_flavor) if (it%is_valid ()) then call it%add_to_matrix_element (value) else call msg_fatal ("Cannot add to matrix element - it%node not allocated") end if end subroutine state_matrix_add_to_matrix_element @ %def state_matrix_add_to_matrix_element @ \subsection{State iterators} Accessing the quantum state from outside is best done using a specialized iterator, i.e., a pointer to a particular branch of the quantum state trie. Technically, the iterator contains a pointer to a leaf node, but via parent pointers it allows to access the whole branch where the leaf is attached. For quick access, we also keep the branch depth (which is assumed to be universal for a quantum state). <>= public :: state_iterator_t <>= type :: state_iterator_t private integer :: depth = 0 type(state_matrix_t), pointer :: state => null () type(node_t), pointer :: node => null () contains <> end type state_iterator_t @ %def state_iterator @ The initializer: Point at the first branch. Note that this cannot be pure, thus not be elemental, because the iterator can be used to manipulate data in the state matrix. <>= procedure :: init => state_iterator_init <>= subroutine state_iterator_init (it, state) class(state_iterator_t), intent(out) :: it type(state_matrix_t), intent(in), target :: state it%state => state it%depth = state%depth if (state%is_defined ()) then it%node => state%root do while (associated (it%node%child_first)) it%node => it%node%child_first end do else it%node => null () end if end subroutine state_iterator_init @ %def state_iterator_init @ Go forward. Recursively programmed: if the next node does not exist, go back to the parent node and look at its successor (if present), etc. There is a possible pitfall in the implementation: If the dummy pointer argument to the [[find_next]] routine is used directly, we still get the correct result for the iterator, but calling the recursion on [[node%parent]] means that we manipulate a parent pointer in the original state in addition to the iterator. Making a local copy of the pointer avoids this. Using pointer intent would be helpful, but we do not yet rely on this F2003 feature. <>= procedure :: advance => state_iterator_advance <>= subroutine state_iterator_advance (it) class(state_iterator_t), intent(inout) :: it call find_next (it%node) contains recursive subroutine find_next (node_in) type(node_t), intent(in), target :: node_in type(node_t), pointer :: node node => node_in if (associated (node%next)) then node => node%next do while (associated (node%child_first)) node => node%child_first end do it%node => node else if (associated (node%parent)) then call find_next (node%parent) else it%node => null () end if end subroutine find_next end subroutine state_iterator_advance @ %def state_iterator_advance @ If all has been scanned, the iterator is at an undefined state. Check for this: <>= procedure :: is_valid => state_iterator_is_valid <>= function state_iterator_is_valid (it) result (defined) logical :: defined class(state_iterator_t), intent(in) :: it defined = associated (it%node) end function state_iterator_is_valid @ %def state_iterator_is_valid @ Return the matrix-element index that corresponds to the current node <>= procedure :: get_me_index => state_iterator_get_me_index <>= function state_iterator_get_me_index (it) result (n) integer :: n class(state_iterator_t), intent(in) :: it n = it%node%me_index end function state_iterator_get_me_index @ %def state_iterator_get_me_index @ Return the number of times this quantum-number state has been added (noting that it is physically inserted only the first time). Note that for each state, there is an array of counters. <>= procedure :: get_me_count => state_iterator_get_me_count <>= function state_iterator_get_me_count (it) result (n) integer, dimension(:), allocatable :: n class(state_iterator_t), intent(in) :: it if (allocated (it%node%me_count)) then allocate (n (size (it%node%me_count))) n = it%node%me_count else allocate (n (0)) end if end function state_iterator_get_me_count @ %def state_iterator_get_me_count @ <>= procedure :: get_depth => state_iterator_get_depth <>= pure function state_iterator_get_depth (state_iterator) result (depth) integer :: depth class(state_iterator_t), intent(in) :: state_iterator depth = state_iterator%depth end function state_iterator_get_depth @ %def state_iterator_get_depth @ Proceed to the state associated with the quantum numbers [[qn]]. <>= procedure :: go_to_qn => state_iterator_go_to_qn <>= subroutine state_iterator_go_to_qn (it, qn, match_only_flavor) class(state_iterator_t), intent(inout) :: it type(quantum_numbers_t), dimension(:), intent(in) :: qn logical, intent(in), optional :: match_only_flavor logical :: match_flv match_flv = .false.; if (present (match_only_flavor)) match_flv = .true. do while (it%is_valid ()) if (match_flv) then if (all (qn .fmatch. it%get_quantum_numbers ())) then return else call it%advance () end if else if (all (qn == it%get_quantum_numbers ())) then return else call it%advance () end if end if end do end subroutine state_iterator_go_to_qn @ %def state_iterator_go_to_qn @ Use the iterator to retrieve quantum-number information: <>= generic :: get_quantum_numbers => get_qn_multi, get_qn_slice, & get_qn_range, get_qn_single generic :: get_flavor => get_flv_multi, get_flv_slice, & get_flv_range, get_flv_single generic :: get_color => get_col_multi, get_col_slice, & get_col_range, get_col_single generic :: get_helicity => get_hel_multi, get_hel_slice, & get_hel_range, get_hel_single <>= procedure :: get_qn_multi => state_iterator_get_qn_multi procedure :: get_qn_slice => state_iterator_get_qn_slice procedure :: get_qn_range => state_iterator_get_qn_range procedure :: get_qn_single => state_iterator_get_qn_single procedure :: get_flv_multi => state_iterator_get_flv_multi procedure :: get_flv_slice => state_iterator_get_flv_slice procedure :: get_flv_range => state_iterator_get_flv_range procedure :: get_flv_single => state_iterator_get_flv_single procedure :: get_col_multi => state_iterator_get_col_multi procedure :: get_col_slice => state_iterator_get_col_slice procedure :: get_col_range => state_iterator_get_col_range procedure :: get_col_single => state_iterator_get_col_single procedure :: get_hel_multi => state_iterator_get_hel_multi procedure :: get_hel_slice => state_iterator_get_hel_slice procedure :: get_hel_range => state_iterator_get_hel_range procedure :: get_hel_single => state_iterator_get_hel_single @ These versions return the whole quantum number array <>= function state_iterator_get_qn_multi (it) result (qn) class(state_iterator_t), intent(in) :: it type(quantum_numbers_t), dimension(it%depth) :: qn type(node_t), pointer :: node integer :: i node => it%node do i = it%depth, 1, -1 qn(i) = node%qn node => node%parent end do end function state_iterator_get_qn_multi function state_iterator_get_flv_multi (it) result (flv) class(state_iterator_t), intent(in) :: it type(flavor_t), dimension(it%depth) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers ()) end function state_iterator_get_flv_multi function state_iterator_get_col_multi (it) result (col) class(state_iterator_t), intent(in) :: it type(color_t), dimension(it%depth) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers ()) end function state_iterator_get_col_multi function state_iterator_get_hel_multi (it) result (hel) class(state_iterator_t), intent(in) :: it type(helicity_t), dimension(it%depth) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers ()) end function state_iterator_get_hel_multi @ An array slice (derived from the above). <>= function state_iterator_get_qn_slice (it, index) result (qn) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(quantum_numbers_t), dimension(size(index)) :: qn type(quantum_numbers_t), dimension(it%depth) :: qn_tmp qn_tmp = state_iterator_get_qn_multi (it) qn = qn_tmp(index) end function state_iterator_get_qn_slice function state_iterator_get_flv_slice (it, index) result (flv) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(flavor_t), dimension(size(index)) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (index)) end function state_iterator_get_flv_slice function state_iterator_get_col_slice (it, index) result (col) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(color_t), dimension(size(index)) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (index)) end function state_iterator_get_col_slice function state_iterator_get_hel_slice (it, index) result (hel) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(helicity_t), dimension(size(index)) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (index)) end function state_iterator_get_hel_slice @ An array range (implemented directly). <>= function state_iterator_get_qn_range (it, k1, k2) result (qn) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(quantum_numbers_t), dimension(k2-k1+1) :: qn type(node_t), pointer :: node integer :: i node => it%node SCAN: do i = it%depth, 1, -1 if (k1 <= i .and. i <= k2) then qn(i-k1+1) = node%qn else node => node%parent end if end do SCAN end function state_iterator_get_qn_range function state_iterator_get_flv_range (it, k1, k2) result (flv) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(flavor_t), dimension(k2-k1+1) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_flv_range function state_iterator_get_col_range (it, k1, k2) result (col) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(color_t), dimension(k2-k1+1) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_col_range function state_iterator_get_hel_range (it, k1, k2) result (hel) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(helicity_t), dimension(k2-k1+1) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_hel_range @ Just a specific single element <>= function state_iterator_get_qn_single (it, k) result (qn) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(quantum_numbers_t) :: qn type(node_t), pointer :: node integer :: i node => it%node SCAN: do i = it%depth, 1, -1 if (i == k) then qn = node%qn exit SCAN else node => node%parent end if end do SCAN end function state_iterator_get_qn_single function state_iterator_get_flv_single (it, k) result (flv) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(flavor_t) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (k)) end function state_iterator_get_flv_single function state_iterator_get_col_single (it, k) result (col) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(color_t) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (k)) end function state_iterator_get_col_single function state_iterator_get_hel_single (it, k) result (hel) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(helicity_t) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (k)) end function state_iterator_get_hel_single @ %def state_iterator_get_quantum_numbers @ %def state_iterator_get_flavor @ %def state_iterator_get_color @ %def state_iterator_get_helicity @ Assign a model pointer to the current flavor entries. <>= procedure :: set_model => state_iterator_set_model <>= subroutine state_iterator_set_model (it, model) class(state_iterator_t), intent(inout) :: it class(model_data_t), intent(in), target :: model type(node_t), pointer :: node integer :: i node => it%node do i = it%depth, 1, -1 call node%qn%set_model (model) node => node%parent end do end subroutine state_iterator_set_model @ %def state_iterator_set_model @ Retrieve the matrix element value associated with the current node. <>= procedure :: get_matrix_element => state_iterator_get_matrix_element <>= function state_iterator_get_matrix_element (it) result (me) complex(default) :: me class(state_iterator_t), intent(in) :: it if (it%state%leaf_nodes_store_values) then me = it%node%me else if (it%node%me_index /= 0) then me = it%state%me(it%node%me_index) else me = 0 end if end function state_iterator_get_matrix_element @ %def state_iterator_get_matrix_element @ Set the matrix element value using the state iterator. <>= procedure :: set_matrix_element => state_iterator_set_matrix_element <>= subroutine state_iterator_set_matrix_element (it, value) class(state_iterator_t), intent(inout) :: it complex(default), intent(in) :: value if (it%node%me_index /= 0) it%state%me(it%node%me_index) = value end subroutine state_iterator_set_matrix_element @ %def state_iterator_set_matrix_element @ <>= procedure :: add_to_matrix_element => state_iterator_add_to_matrix_element <>= subroutine state_iterator_add_to_matrix_element (it, value) class(state_iterator_t), intent(inout) :: it complex(default), intent(in) :: value if (it%node%me_index /= 0) & it%state%me(it%node%me_index) = it%state%me(it%node%me_index) + value end subroutine state_iterator_add_to_matrix_element @ %def state_iterator_add_to_matrix_element @ \subsection{Operations on quantum states} Return a deep copy of a state matrix. <>= public :: assignment(=) <>= interface assignment(=) module procedure state_matrix_assign end interface <>= subroutine state_matrix_assign (state_out, state_in) type(state_matrix_t), intent(out) :: state_out type(state_matrix_t), intent(in), target :: state_in type(state_iterator_t) :: it if (.not. state_in%is_defined ()) return call state_out%init () call it%init (state_in) do while (it%is_valid ()) call state_out%add_state (it%get_quantum_numbers (), & it%get_me_index ()) call it%advance () end do if (allocated (state_in%me)) then allocate (state_out%me (size (state_in%me))) state_out%me = state_in%me end if state_out%n_sub = state_in%n_sub end subroutine state_matrix_assign @ %def state_matrix_assign @ Determine the indices of all diagonal matrix elements. <>= procedure :: get_diagonal_entries => state_matrix_get_diagonal_entries <>= subroutine state_matrix_get_diagonal_entries (state, i) class(state_matrix_t), intent(in) :: state integer, dimension(:), allocatable, intent(out) :: i integer, dimension(state%n_matrix_elements) :: tmp integer :: n type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn n = 0 call it%init (state) allocate (qn (it%depth)) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (all (qn%are_diagonal ())) then n = n + 1 tmp(n) = it%get_me_index () end if call it%advance () end do allocate (i(n)) if (n > 0) i = tmp(:n) end subroutine state_matrix_get_diagonal_entries @ %def state_matrices_get_diagonal_entries @ Normalize all matrix elements, i.e., multiply by a common factor. Assuming that the factor is nonzero, of course. <>= procedure :: renormalize => state_matrix_renormalize <>= subroutine state_matrix_renormalize (state, factor) class(state_matrix_t), intent(inout) :: state complex(default), intent(in) :: factor state%me = state%me * factor end subroutine state_matrix_renormalize @ %def state_matrix_renormalize @ Renormalize the state matrix by its trace, if nonzero. The renormalization is reflected in the state-matrix norm. <>= procedure :: normalize_by_trace => state_matrix_normalize_by_trace <>= subroutine state_matrix_normalize_by_trace (state) class(state_matrix_t), intent(inout) :: state real(default) :: trace trace = state%trace () if (trace /= 0) then state%me = state%me / trace state%norm = state%norm * trace end if end subroutine state_matrix_normalize_by_trace @ %def state_matrix_renormalize_by_trace @ Analogous, but renormalize by maximal (absolute) value. <>= procedure :: normalize_by_max => state_matrix_normalize_by_max <>= subroutine state_matrix_normalize_by_max (state) class(state_matrix_t), intent(inout) :: state real(default) :: m m = maxval (abs (state%me)) if (m /= 0) then state%me = state%me / m state%norm = state%norm * m end if end subroutine state_matrix_normalize_by_max @ %def state_matrix_renormalize_by_max @ Explicitly set the norm of a state matrix. <>= procedure :: set_norm => state_matrix_set_norm <>= subroutine state_matrix_set_norm (state, norm) class(state_matrix_t), intent(inout) :: state real(default), intent(in) :: norm state%norm = norm end subroutine state_matrix_set_norm @ %def state_matrix_set_norm @ Return the sum of all matrix element values. <>= procedure :: sum => state_matrix_sum <>= pure function state_matrix_sum (state) result (value) complex(default) :: value class(state_matrix_t), intent(in) :: state value = sum (state%me) end function state_matrix_sum @ %def state_matrix_sum @ Return the trace of a state matrix, i.e., the sum over all diagonal values. If [[qn_in]] is provided, only branches that match this quantum-numbers array in flavor and helicity are considered. (This mode is used for selecting a color state.) <>= procedure :: trace => state_matrix_trace <>= function state_matrix_trace (state, qn_in) result (trace) complex(default) :: trace class(state_matrix_t), intent(in), target :: state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_iterator_t) :: it allocate (qn (state%get_depth ())) trace = 0 call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (present (qn_in)) then if (.not. all (qn .fhmatch. qn_in)) then call it%advance (); cycle end if end if if (all (qn%are_diagonal ())) then trace = trace + it%get_matrix_element () end if call it%advance () end do end function state_matrix_trace @ %def state_matrix_trace @ Append new states which are color-contracted versions of the existing states. The matrix element index of each color contraction coincides with the index of its origin, so no new matrix elements are generated. After this operation, no [[freeze]] must be performed anymore. <>= procedure :: add_color_contractions => state_matrix_add_color_contractions <>= subroutine state_matrix_add_color_contractions (state) class(state_matrix_t), intent(inout), target :: state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:,:), allocatable :: qn type(quantum_numbers_t), dimension(:,:), allocatable :: qn_con integer, dimension(:), allocatable :: me_index integer :: depth, n_me, i, j depth = state%get_depth () n_me = state%get_n_matrix_elements () allocate (qn (depth, n_me)) allocate (me_index (n_me)) i = 0 call it%init (state) do while (it%is_valid ()) i = i + 1 qn(:,i) = it%get_quantum_numbers () me_index(i) = it%get_me_index () call it%advance () end do do i = 1, n_me call quantum_number_array_make_color_contractions (qn(:,i), qn_con) do j = 1, size (qn_con, 2) call state%add_state (qn_con(:,j), index = me_index(i)) end do end do end subroutine state_matrix_add_color_contractions @ %def state_matrix_add_color_contractions @ This procedure merges two state matrices of equal depth. For each quantum number (flavor, color, helicity), we take the entry from the first argument where defined, otherwise the second one. (If both are defined, we get an off-diagonal matrix.) The resulting trie combines the information of the input tries in all possible ways. Note that values are ignored, all values in the result are zero. <>= public :: merge_state_matrices <>= subroutine merge_state_matrices (state1, state2, state3) type(state_matrix_t), intent(in), target :: state1, state2 type(state_matrix_t), intent(out) :: state3 type(state_iterator_t) :: it1, it2 type(quantum_numbers_t), dimension(state1%depth) :: qn1, qn2 if (state1%depth /= state2%depth) then call state1%write () call state2%write () call msg_bug ("State matrices merge impossible: incompatible depths") end if call state3%init () call it1%init (state1) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () call it2%init (state2) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () call state3%add_state (qn1 .merge. qn2) call it2%advance () end do call it1%advance () end do call state3%freeze () end subroutine merge_state_matrices @ %def merge_state_matrices @ Multiply matrix elements from two state matrices. Choose the elements as given by the integer index arrays, multiply them and store the sum of products in the indicated matrix element. The suffixes mean: c=conjugate first factor; f=include weighting factor. Note that the [[dot_product]] intrinsic function conjugates its first complex argument. This is intended for the [[c]] suffix case, but must be reverted for the plain-product case. We provide analogous subroutines for just summing over state matrix entries. The [[evaluate_sum]] variant includes the state-matrix norm in the evaluation, the [[evaluate_me_sum]] takes into account just the matrix elements proper. <>= procedure :: evaluate_product => state_matrix_evaluate_product procedure :: evaluate_product_cf => state_matrix_evaluate_product_cf procedure :: evaluate_square_c => state_matrix_evaluate_square_c procedure :: evaluate_sum => state_matrix_evaluate_sum procedure :: evaluate_me_sum => state_matrix_evaluate_me_sum <>= pure subroutine state_matrix_evaluate_product & (state, i, state1, state2, index1, index2) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1, state2 integer, dimension(:), intent(in) :: index1, index2 state%me(i) = & dot_product (conjg (state1%me(index1)), state2%me(index2)) state%norm = state1%norm * state2%norm end subroutine state_matrix_evaluate_product pure subroutine state_matrix_evaluate_product_cf & (state, i, state1, state2, index1, index2, factor) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1, state2 integer, dimension(:), intent(in) :: index1, index2 complex(default), dimension(:), intent(in) :: factor state%me(i) = & dot_product (state1%me(index1), factor * state2%me(index2)) state%norm = state1%norm * state2%norm end subroutine state_matrix_evaluate_product_cf pure subroutine state_matrix_evaluate_square_c (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = & dot_product (state1%me(index1), state1%me(index1)) state%norm = abs (state1%norm) ** 2 end subroutine state_matrix_evaluate_square_c pure subroutine state_matrix_evaluate_sum (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = & sum (state1%me(index1)) * state1%norm end subroutine state_matrix_evaluate_sum pure subroutine state_matrix_evaluate_me_sum (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = sum (state1%me(index1)) end subroutine state_matrix_evaluate_me_sum @ %def state_matrix_evaluate_product @ %def state_matrix_evaluate_product_cf @ %def state_matrix_evaluate_square_c @ %def state_matrix_evaluate_sum @ %def state_matrix_evaluate_me_sum @ Outer product (of states and matrix elements): <>= public :: outer_multiply <>= interface outer_multiply module procedure outer_multiply_pair module procedure outer_multiply_array end interface @ %def outer_multiply @ This procedure constructs the outer product of two state matrices. <>= subroutine outer_multiply_pair (state1, state2, state3) type(state_matrix_t), intent(in), target :: state1, state2 type(state_matrix_t), intent(out) :: state3 type(state_iterator_t) :: it1, it2 type(quantum_numbers_t), dimension(state1%depth) :: qn1 type(quantum_numbers_t), dimension(state2%depth) :: qn2 type(quantum_numbers_t), dimension(state1%depth+state2%depth) :: qn3 complex(default) :: val1, val2 call state3%init (store_values = .true.) call it1%init (state1) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () val1 = it1%get_matrix_element () call it2%init (state2) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () val2 = it2%get_matrix_element () qn3(:state1%depth) = qn1 qn3(state1%depth+1:) = qn2 call state3%add_state (qn3, value=val1 * val2) call it2%advance () end do call it1%advance () end do call state3%freeze () end subroutine outer_multiply_pair @ %def outer_multiply_state_pair @ This executes the above routine iteratively for an arbitrary number of state matrices. <>= subroutine outer_multiply_array (state_in, state_out) type(state_matrix_t), dimension(:), intent(in), target :: state_in type(state_matrix_t), intent(out) :: state_out type(state_matrix_t), dimension(:), allocatable, target :: state_tmp integer :: i, n n = size (state_in) select case (n) case (0) call state_out%init () case (1) state_out = state_in(1) case (2) call outer_multiply_pair (state_in(1), state_in(2), state_out) case default allocate (state_tmp (n-2)) call outer_multiply_pair (state_in(1), state_in(2), state_tmp(1)) do i = 2, n - 2 call outer_multiply_pair (state_tmp(i-1), state_in(i+1), state_tmp(i)) end do call outer_multiply_pair (state_tmp(n-2), state_in(n), state_out) do i = 1, size(state_tmp) call state_tmp(i)%final () end do end select end subroutine outer_multiply_array @ %def outer_multiply_pair @ %def outer_multiply_array @ \subsection{Factorization} In physical events, the state matrix is factorized into single-particle state matrices. This is essentially a measurement. In a simulation, we select one particular branch of the state matrix with a probability that is determined by the matrix elements at the leaves. (This makes sense only if the state matrix represents a squared amplitude.) The selection is based on a (random) value [[x]] between 0 and one that is provided as the third argument. For flavor and color, we select a unique value for each particle. For polarization, we have three options (modes). Option 1 is to drop helicity information altogether and sum over all diagonal helicities. Option 2 is to select a unique diagonal helicity in the same way as flavor and color. Option 3 is, for each particle, to trace over all remaining helicities in order to obtain an array of independent single-particle helicity matrices. Only branches that match the given quantum-number array [[qn_in]], if present, are considered. For this array, color is ignored. If the optional [[correlated_state]] is provided, it is assigned the correlated density matrix for the selected flavor-color branch, so multi-particle spin correlations remain available even if they are dropped in the single-particle density matrices. This should be done by the caller for the choice [[FM_CORRELATED_HELICITY]], which otherwise is handled as [[FM_IGNORE_HELICITY]]. The algorithm is as follows: First, we determine the normalization by summing over all diagonal matrix elements. In a second scan, we select one of the diagonal matrix elements by a cumulative comparison with the normalized random number. In the corresponding quantum number array, we undefine the helicity entries. Then, we scan the third time. For each branch that matches the selected quantum number array (i.e., definite flavor and color, arbitrary helicity), we determine its contribution to any of the single-particle state matrices. The matrix-element value is added if all other quantum numbers are diagonal, while the helicity of the chosen particle may be arbitrary; this helicity determines the branch in the single-particle state. As a result, flavor and color quantum numbers are selected with the correct probability. Within this subset of states, each single-particle state matrix results from tracing over all other particles. Note that the single-particle state matrices are not normalized. The flag [[ok]] is set to false if the matrix element sum is zero, so factorization is not possible. This can happen if an event did not pass cuts. <>= integer, parameter, public :: FM_IGNORE_HELICITY = 1 integer, parameter, public :: FM_SELECT_HELICITY = 2 integer, parameter, public :: FM_FACTOR_HELICITY = 3 integer, parameter, public :: FM_CORRELATED_HELICITY = 4 @ %def FM_IGNORE_HELICITY FM_SELECT_HELICITY FM_FACTOR_HELICITY @ %def FM_CORRELATED_HELICITY <>= procedure :: factorize => state_matrix_factorize <>= subroutine state_matrix_factorize & (state, mode, x, ok, single_state, correlated_state, qn_in) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: mode real(default), intent(in) :: x logical, intent(out) :: ok type(state_matrix_t), & dimension(:), allocatable, intent(out) :: single_state type(state_matrix_t), intent(out), optional :: correlated_state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in type(state_iterator_t) :: it real(default) :: s, xt complex(default) :: value integer :: i, depth type(quantum_numbers_t), dimension(:), allocatable :: qn, qn1 type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical, dimension(:), allocatable :: diagonal logical, dimension(:,:), allocatable :: mask ok = .true. if (x /= 0) then xt = x * abs (state%trace (qn_in)) else xt = 0 end if s = 0 depth = state%get_depth () allocate (qn (depth), qn1 (depth), diagonal (depth)) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (present (qn_in)) then if (.not. all (qn .fhmatch. qn_in)) then call it%advance (); cycle end if end if if (all (qn%are_diagonal ())) then value = abs (it%get_matrix_element ()) s = s + value if (s > xt) exit end if call it%advance () end do if (.not. it%is_valid ()) then if (s == 0) ok = .false. call it%init (state) end if allocate (single_state (depth)) do i = 1, depth call single_state(i)%init (store_values = .true.) end do if (present (correlated_state)) & call correlated_state%init (store_values = .true.) qn = it%get_quantum_numbers () select case (mode) case (FM_SELECT_HELICITY) ! single branch selected; shortcut do i = 1, depth call single_state(i)%add_state ([qn(i)], value=value) end do if (.not. present (correlated_state)) then do i = 1, size(single_state) call single_state(i)%freeze () end do return end if end select allocate (qn_mask (depth)) call qn_mask%init (.false., .false., .false., .true.) call qn%undefine (qn_mask) select case (mode) case (FM_FACTOR_HELICITY) allocate (mask (depth, depth)) mask = .false. forall (i = 1:depth) mask(i,i) = .true. end select call it%init (state) do while (it%is_valid ()) qn1 = it%get_quantum_numbers () if (all (qn .match. qn1)) then diagonal = qn1%are_diagonal () value = it%get_matrix_element () select case (mode) case (FM_IGNORE_HELICITY, FM_CORRELATED_HELICITY) !!! trace over diagonal states that match qn if (all (diagonal)) then do i = 1, depth call single_state(i)%add_state & ([qn(i)], value=value, sum_values=.true.) end do end if case (FM_FACTOR_HELICITY) !!! trace over all other particles do i = 1, depth if (all (diagonal .or. mask(:,i))) then call single_state(i)%add_state & ([qn1(i)], value=value, sum_values=.true.) end if end do end select if (present (correlated_state)) & call correlated_state%add_state (qn1, value=value) end if call it%advance () end do do i = 1, depth call single_state(i)%freeze () end do if (present (correlated_state)) & call correlated_state%freeze () end subroutine state_matrix_factorize @ %def state_matrix_factorize @ \subsubsection{Auxiliary functions} <>= procedure :: get_polarization_density_matrix & => state_matrix_get_polarization_density_matrix <>= function state_matrix_get_polarization_density_matrix (state) result (pol_matrix) real(default), dimension(:,:), allocatable :: pol_matrix class(state_matrix_t), intent(in) :: state type(node_t), pointer :: current => null () !!! What's the generic way to allocate the matrix? allocate (pol_matrix (4,4)); pol_matrix = 0 if (associated (state%root%child_first)) then current => state%root%child_first do while (associated (current)) call current%qn%write () current => current%next end do else call msg_fatal ("Polarization state not allocated!") end if end function state_matrix_get_polarization_density_matrix @ %def state_matrix_get_polarization_density_matrix @ \subsubsection{Quantum-number matching} This feature allows us to check whether a given string of PDG values matches, in any ordering, any of the flavor combinations that the state matrix provides. We will also request the permutation of the successful match. This type provides an account of the state's flavor content. We store all flavor combinations, as [[pdg]] values, in an array, assuming that the length is uniform. We check only the entries selected by [[mask_match]]. Among those, only the entries selected by [[mask_sort]] are sorted and thus matched without respecting array element order. The entries that correspond to a true value in the associated [[mask]] are sorted. The mapping from the original state to the sorted state is given by the index array [[map]]. <>= public :: state_flv_content_t <>= type :: state_flv_content_t private integer, dimension(:,:), allocatable :: pdg integer, dimension(:,:), allocatable :: map logical, dimension(:), allocatable :: mask contains <> end type state_flv_content_t @ %def state_matrix_flavor_content @ Output (debugging aid). <>= procedure :: write => state_flv_content_write <>= subroutine state_flv_content_write (state_flv, unit) class(state_flv_content_t), intent(in), target :: state_flv integer, intent(in), optional :: unit integer :: u, n, d, i, j u = given_output_unit (unit) d = size (state_flv%pdg, 1) n = size (state_flv%pdg, 2) do i = 1, n write (u, "(2x,'PDG =')", advance="no") do j = 1, d write (u, "(1x,I0)", advance="no") state_flv%pdg(j,i) end do write (u, "(' :: map = (')", advance="no") do j = 1, d write (u, "(1x,I0)", advance="no") state_flv%map(j,i) end do write (u, "(' )')") end do end subroutine state_flv_content_write @ %def state_flv_content_write @ Initialize with table length and mask. Each row of the [[map]] array, of length $d$, is initialized with $(0,1,\ldots,d)$. <>= procedure :: init => state_flv_content_init <>= subroutine state_flv_content_init (state_flv, n, mask) class(state_flv_content_t), intent(out) :: state_flv integer, intent(in) :: n logical, dimension(:), intent(in) :: mask integer :: d, i d = size (mask) allocate (state_flv%pdg (d, n), source = 0) allocate (state_flv%map (d, n), source = spread ([(i, i = 1, d)], 2, n)) allocate (state_flv%mask (d), source = mask) end subroutine state_flv_content_init @ %def state_flv_content_init @ Manually fill the entries, one flavor set and mapping at a time. <>= procedure :: set_entry => state_flv_content_set_entry <>= subroutine state_flv_content_set_entry (state_flv, i, pdg, map) class(state_flv_content_t), intent(inout) :: state_flv integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg, map state_flv%pdg(:,i) = pdg where (map /= 0) state_flv%map(:,i) = map end where end subroutine state_flv_content_set_entry @ %def state_flv_content_set_entry @ Given a state matrix, determine the flavor content. That is, scan the state matrix and extract flavor only, build a new state matrix from that. <>= procedure :: fill => state_flv_content_fill <>= subroutine state_flv_content_fill & (state_flv, state_full, mask) class(state_flv_content_t), intent(out) :: state_flv type(state_matrix_t), intent(in), target :: state_full logical, dimension(:), intent(in) :: mask type(state_matrix_t), target :: state_tmp type(state_iterator_t) :: it type(flavor_t), dimension(:), allocatable :: flv integer, dimension(:), allocatable :: pdg, pdg_subset integer, dimension(:), allocatable :: idx, map_subset, idx_subset, map type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: n, d, c, i, j call state_tmp%init () d = state_full%get_depth () allocate (flv (d), qn (d), pdg (d), idx (d), map (d)) idx = [(i, i = 1, d)] c = count (mask) allocate (pdg_subset (c), map_subset (c), idx_subset (c)) call it%init (state_full) do while (it%is_valid ()) flv = it%get_flavor () call qn%init (flv) call state_tmp%add_state (qn) call it%advance () end do n = state_tmp%get_n_leaves () call state_flv%init (n, mask) i = 0 call it%init (state_tmp) do while (it%is_valid ()) i = i + 1 flv = it%get_flavor () pdg = flv%get_pdg () idx_subset = pack (idx, mask) pdg_subset = pack (pdg, mask) map_subset = order_abs (pdg_subset) map = unpack (idx_subset (map_subset), mask, idx) call state_flv%set_entry (i, & unpack (pdg_subset(map_subset), mask, pdg), & order (map)) call it%advance () end do call state_tmp%final () end subroutine state_flv_content_fill @ %def state_flv_content_fill @ Match a given flavor string against the flavor content. We sort the input string and check whether it matches any of the stored strings. If yes, return the mapping. Only PDG entries under the preset mask are sorted before matching. The other entries must match exactly (i.e., without reordering). A zero entry matches anything. In any case, the length of the PDG string must be equal to the length $d$ of the individual flavor-state entries. <>= procedure :: match => state_flv_content_match <>= subroutine state_flv_content_match (state_flv, pdg, success, map) class(state_flv_content_t), intent(in) :: state_flv integer, dimension(:), intent(in) :: pdg logical, intent(out) :: success integer, dimension(:), intent(out) :: map integer, dimension(:), allocatable :: pdg_subset, pdg_sorted, map1, map2 integer, dimension(:), allocatable :: idx, map_subset, idx_subset integer :: i, n, c, d c = count (state_flv%mask) d = size (state_flv%pdg, 1) n = size (state_flv%pdg, 2) allocate (idx (d), source = [(i, i = 1, d)]) allocate (idx_subset (c), pdg_subset (c), map_subset (c)) allocate (pdg_sorted (d), map1 (d), map2 (d)) idx_subset = pack (idx, state_flv%mask) pdg_subset = pack (pdg, state_flv%mask) map_subset = order_abs (pdg_subset) pdg_sorted = unpack (pdg_subset(map_subset), state_flv%mask, pdg) success = .false. do i = 1, n if (all (pdg_sorted == state_flv%pdg(:,i) & .or. pdg_sorted == 0)) then success = .true. exit end if end do if (success) then map1 = state_flv%map(:,i) map2 = unpack (idx_subset(map_subset), state_flv%mask, idx) map = map2(map1) where (pdg == 0) map = 0 end if end subroutine state_flv_content_match @ %def state_flv_content_match @ <>= elemental function pacify_complex (c_in) result (c_pac) complex(default), intent(in) :: c_in complex(default) :: c_pac c_pac = c_in if (real(c_pac) == -real(c_pac)) then c_pac = & cmplx (0._default, aimag(c_pac), kind=default) end if if (aimag(c_pac) == -aimag(c_pac)) then c_pac = & cmplx (real(c_pac), 0._default, kind=default) end if end function pacify_complex @ %def pacify_complex @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[state_matrices_ut.f90]]>>= <> module state_matrices_ut use unit_tests use state_matrices_uti <> <> contains <> end module state_matrices_ut @ %def state_matrices_ut @ <<[[state_matrices_uti.f90]]>>= <> module state_matrices_uti <> use io_units use format_defs, only: FMT_19 use flavors use colors use helicities use quantum_numbers use state_matrices <> <> contains <> end module state_matrices_uti @ %def state_matrices_ut @ API: driver for the unit tests below. <>= public :: state_matrix_test <>= subroutine state_matrix_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine state_matrix_test @ %def state_matrix_test @ Create two quantum states of equal depth and merge them. <>= call test (state_matrix_1, "state_matrix_1", & "check merge of quantum states of equal depth", & u, results) <>= public :: state_matrix_1 <>= subroutine state_matrix_1 (u) integer, intent(in) :: u type(state_matrix_t) :: state1, state2, state3 type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(quantum_numbers_t), dimension(3) :: qn write (u, "(A)") "* Test output: state_matrix_1" write (u, "(A)") "* Purpose: create and merge two quantum states" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") write (u, "(A)") "* State matrix 1" write (u, "(A)") call state1%init () call flv%init ([1, 2, 11]) call qn%init (flv, helicity ([ 1, 1, 1])) call state1%add_state (qn) call qn%init (flv, helicity ([ 1, 1, 1], [-1, 1, -1])) call state1%add_state (qn) call state1%freeze () call state1%write (u) write (u, "(A)") write (u, "(A)") "* State matrix 2" write (u, "(A)") call state2%init () call col(1)%init ([501]) call col(2)%init ([-501]) call col(3)%init ([0]) call qn%init (col, helicity ([-1, -1, 0])) call state2%add_state (qn) call col(3)%init ([99]) call qn%init (col, helicity ([-1, -1, 0])) call state2%add_state (qn) call state2%freeze () call state2%write (u) write (u, "(A)") write (u, "(A)") "* Merge the state matrices" write (u, "(A)") call merge_state_matrices (state1, state2, state3) call state3%write (u) write (u, "(A)") write (u, "(A)") "* Collapse the state matrix" write (u, "(A)") call state3%collapse (quantum_numbers_mask (.false., .false., & [.true.,.false.,.false.])) call state3%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call state1%final () call state2%final () call state3%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_1" write (u, "(A)") end subroutine state_matrix_1 @ %def state_matrix_1 @ Create a correlated three-particle state matrix and factorize it. <>= call test (state_matrix_2, "state_matrix_2", & "check factorizing 3-particle state matrix", & u, results) <>= public :: state_matrix_2 <>= subroutine state_matrix_2 (u) integer, intent(in) :: u type(state_matrix_t) :: state type(state_matrix_t), dimension(:), allocatable :: single_state type(state_matrix_t) :: correlated_state integer :: f, h11, h12, h21, h22, i, mode type(flavor_t), dimension(2) :: flv type(color_t), dimension(2) :: col type(helicity_t), dimension(2) :: hel type(quantum_numbers_t), dimension(2) :: qn logical :: ok write (u, "(A)") write (u, "(A)") "* Test output: state_matrix_2" write (u, "(A)") "* Purpose: factorize correlated 3-particle state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call state%init () do f = 1, 2 do h11 = -1, 1, 2 do h12 = -1, 1, 2 do h21 = -1, 1, 2 do h22 = -1, 1, 2 call flv%init ([f, -f]) call col(1)%init ([1]) call col(2)%init ([-1]) call hel%init ([h11,h12], [h21, h22]) call qn%init (flv, col, hel) call state%add_state (qn) end do end do end do end do end do call state%freeze () call state%write (u) write (u, "(A)") write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "* Trace = ", state%trace () write (u, "(A)") do mode = 1, 3 write (u, "(A)") write (u, "(A,I1)") "* Mode = ", mode call state%factorize & (mode, 0.15_default, ok, single_state, correlated_state) do i = 1, size (single_state) write (u, "(A)") call single_state(i)%write (u) write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "Trace = ", single_state(i)%trace () end do write (u, "(A)") call correlated_state%write (u) write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "Trace = ", correlated_state%trace () do i = 1, size(single_state) call single_state(i)%final () end do call correlated_state%final () end do write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_2" end subroutine state_matrix_2 @ %def state_matrix_2 @ Create a colored state matrix and add color contractions. <>= call test (state_matrix_3, "state_matrix_3", & "check factorizing 3-particle state matrix", & u, results) <>= public :: state_matrix_3 <>= subroutine state_matrix_3 (u) use physics_defs, only: HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET integer, intent(in) :: u type(state_matrix_t) :: state type(flavor_t), dimension(4) :: flv type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn write (u, "(A)") "* Test output: state_matrix_3" write (u, "(A)") "* Purpose: add color connections to colored state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call state%init () call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, -1, HADRON_REMNANT_TRIPLET ]) call col(1)%init ([17]) call col(2)%init ([-17]) call col(3)%init ([-19]) call col(4)%init ([19]) call qn%init (flv, col) call state%add_state (qn) call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, 21, HADRON_REMNANT_OCTET ]) call col(1)%init ([17]) call col(2)%init ([-17]) call col(3)%init ([3, -5]) call col(4)%init ([5, -3]) call qn%init (flv, col) call state%add_state (qn) call state%freeze () write (u, "(A)") "* State:" write (u, "(A)") call state%write (u) call state%add_color_contractions () write (u, "(A)") "* State with contractions:" write (u, "(A)") call state%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrx_3" end subroutine state_matrix_3 @ %def state_matrix_3 @ Create a correlated three-particle state matrix, write it to file and read again. <>= call test (state_matrix_4, "state_matrix_4", & "check raw I/O", & u, results) <>= public :: state_matrix_4 <>= subroutine state_matrix_4 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state integer :: f, h11, h12, h21, h22, i type(flavor_t), dimension(2) :: flv type(color_t), dimension(2) :: col type(helicity_t), dimension(2) :: hel type(quantum_numbers_t), dimension(2) :: qn integer :: unit, iostat write (u, "(A)") write (u, "(A)") "* Test output: state_matrix_4" write (u, "(A)") "* Purpose: raw I/O for correlated 3-particle state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") allocate (state) call state%init () do f = 1, 2 do h11 = -1, 1, 2 do h12 = -1, 1, 2 do h21 = -1, 1, 2 do h22 = -1, 1, 2 call flv%init ([f, -f]) call col(1)%init ([1]) call col(2)%init ([-1]) call hel%init ([h11, h12], [h21, h22]) call qn%init (flv, col, hel) call state%add_state (qn) end do end do end do end do end do call state%freeze () call state%set_norm (3._default) do i = 1, state%get_n_leaves () call state%set_matrix_element (i, cmplx (2 * i, 2 * i + 1, default)) end do call state%write (u) write (u, "(A)") write (u, "(A)") "* Write to file and read again " write (u, "(A)") unit = free_unit () open (unit, action="readwrite", form="unformatted", status="scratch") call state%write_raw (unit) call state%final () deallocate (state) allocate(state) rewind (unit) call state%read_raw (unit, iostat=iostat) close (unit) call state%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () deallocate (state) write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_4" end subroutine state_matrix_4 @ %def state_matrix_4 @ Create a flavor-content object for a given state matrix and match it against trial flavor (i.e., PDG) strings. <>= call test (state_matrix_5, "state_matrix_5", & "check flavor content", & u, results) <>= public :: state_matrix_5 <>= subroutine state_matrix_5 (u) integer, intent(in) :: u type(state_matrix_t), allocatable, target :: state type(state_iterator_t) :: it type(state_flv_content_t), allocatable :: state_flv type(flavor_t), dimension(4) :: flv1, flv2, flv3, flv4 type(color_t), dimension(4) :: col1, col2 type(helicity_t), dimension(4) :: hel1, hel2, hel3 type(quantum_numbers_t), dimension(4) :: qn logical, dimension(4) :: mask write (u, "(A)") "* Test output: state_matrix_5" write (u, "(A)") "* Purpose: check flavor-content state" write (u, "(A)") write (u, "(A)") "* Set up arbitrary state matrix" write (u, "(A)") call flv1%init ([1, 4, 2, 7]) call flv2%init ([1, 3,-3, 8]) call flv3%init ([5, 6, 3, 7]) call flv4%init ([6, 3, 5, 8]) call hel1%init ([0, 1, -1, 0]) call hel2%init ([0, 1, 1, 1]) call hel3%init ([1, 0, 0, 0]) call col1(1)%init ([0]) call col1(2)%init ([0]) call col1(3)%init ([0]) call col1(4)%init ([0]) call col2(1)%init ([5, -6]) call col2(2)%init ([0]) call col2(3)%init ([6, -5]) call col2(4)%init ([0]) allocate (state) call state%init () call qn%init (flv1, col1, hel1) call state%add_state (qn) call qn%init (flv1, col1, hel2) call state%add_state (qn) call qn%init (flv3, col1, hel3) call state%add_state (qn) call qn%init (flv4, col1, hel3) call state%add_state (qn) call qn%init (flv1, col2, hel3) call state%add_state (qn) call qn%init (flv2, col2, hel2) call state%add_state (qn) call qn%init (flv2, col2, hel1) call state%add_state (qn) call qn%init (flv2, col1, hel1) call state%add_state (qn) call qn%init (flv3, col1, hel1) call state%add_state (qn) call qn%init (flv3, col2, hel3) call state%add_state (qn) call qn%init (flv1, col1, hel1) call state%add_state (qn) write (u, "(A)") "* Quantum number content" write (u, "(A)") call it%init (state) do while (it%is_valid ()) call quantum_numbers_write (it%get_quantum_numbers (), u) write (u, *) call it%advance () end do write (u, "(A)") write (u, "(A)") "* Extract the flavor content" write (u, "(A)") mask = [.true., .true., .true., .false.] allocate (state_flv) call state_flv%fill (state, mask) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Match trial sets" write (u, "(A)") call check ([1, 2, 3, 0]) call check ([1, 4, 2, 0]) call check ([4, 2, 1, 0]) call check ([1, 3, -3, 0]) call check ([1, -3, 3, 0]) call check ([6, 3, 5, 0]) write (u, "(A)") write (u, "(A)") "* Determine the flavor content with mask" write (u, "(A)") mask = [.false., .true., .true., .false.] call state_flv%fill (state, mask) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Match trial sets" write (u, "(A)") call check ([1, 2, 3, 0]) call check ([1, 4, 2, 0]) call check ([4, 2, 1, 0]) call check ([1, 3, -3, 0]) call check ([1, -3, 3, 0]) call check ([6, 3, 5, 0]) write (u, "(A)") write (u, "(A)") "* Cleanup" deallocate (state_flv) call state%final () deallocate (state) write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_5" contains subroutine check (pdg) integer, dimension(4), intent(in) :: pdg integer, dimension(4) :: map logical :: success call state_flv%match (pdg, success, map) write (u, "(2x,4(1x,I0),':',1x,L1)", advance="no") pdg, success if (success) then write (u, "(2x,'map = (',4(1x,I0),' )')") map else write (u, *) end if end subroutine check end subroutine state_matrix_5 @ %def state_matrix_5 @ Create a state matrix with full flavor, color and helicity information. Afterwards, reduce such that it is only differential in flavor and initial-state helicities. This is used when preparing states for beam- polarized computations with external matrix element providers. <>= call test (state_matrix_6, "state_matrix_6", & "check state matrix reduction", & u, results) <>= public :: state_matrix_6 <>= subroutine state_matrix_6 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state_orig, state_reduced type(flavor_t), dimension(4) :: flv type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: h1, h2, h3 , h4 integer :: n_states = 0 write (u, "(A)") "* Test output: state_matrix_6" write (u, "(A)") "* Purpose: Check state matrix reduction" write (u, "(A)") write (u, "(A)") "* Set up helicity-diagonal state matrix" write (u, "(A)") allocate (state_orig) call state_orig%init () call flv%init ([11, -11, 1, -1]) call col(3)%init ([1]) call col(4)%init ([-1]) 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]) call qn%init (flv, col, hel) call state_orig%add_state (qn) end do end do end do end do call state_orig%freeze () write (u, "(A)") "* Original state: " write (u, "(A)") call state_orig%write (u) write (u, "(A)") write (u, "(A)") "* Setup quantum mask: " call qn_mask%init ([.false., .false., .false., .false.], & [.true., .true., .true., .true.], & [.false., .false., .true., .true.]) call quantum_numbers_mask_write (qn_mask, u) write (u, "(A)") write (u, "(A)") "* Reducing the state matrix using above mask" write (u, "(A)") allocate (state_reduced) call state_orig%reduce (qn_mask, state_reduced) write (u, "(A)") "* Reduced state matrix: " call state_reduced%write (u) write (u, "(A)") "* Test output end: state_matrix_6" end subroutine state_matrix_6 @ %def state_matrix_6 @ Create a state matrix with full flavor, color and helicity information. Afterwards, reduce such that it is only differential in flavor and initial-state helicities, and keeping old indices. Afterwards reorder the reduced state matrix in accordance to the original state matrix. <>= call test (state_matrix_7, "state_matrix_7", & "check ordered state matrix reduction", & u, results) <>= public :: state_matrix_7 <>= subroutine state_matrix_7 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state_orig, state_reduced, & state_ordered type(flavor_t), dimension(4) :: flv type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: h1, h2, h3 , h4 integer :: n_states = 0 write (u, "(A)") "* Test output: state_matrix_7" write (u, "(A)") "* Purpose: Check ordered state matrix reduction" write (u, "(A)") write (u, "(A)") "* Set up helicity-diagonal state matrix" write (u, "(A)") allocate (state_orig) call state_orig%init () call flv%init ([11, -11, 1, -1]) call col(3)%init ([1]) call col(4)%init ([-1]) 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]) call qn%init (flv, col, hel) call state_orig%add_state (qn) end do end do end do end do call state_orig%freeze () write (u, "(A)") "* Original state: " write (u, "(A)") call state_orig%write (u) write (u, "(A)") write (u, "(A)") "* Setup quantum mask: " call qn_mask%init ([.false., .false., .false., .false.], & [.true., .true., .true., .true.], & [.false., .false., .true., .true.]) call quantum_numbers_mask_write (qn_mask, u) write (u, "(A)") write (u, "(A)") "* Reducing the state matrix using above mask and keeping the old indices:" write (u, "(A)") allocate (state_reduced) call state_orig%reduce (qn_mask, state_reduced, keep_me_index = .true.) write (u, "(A)") "* Reduced state matrix with kept indices: " call state_reduced%write (u) write (u, "(A)") write (u, "(A)") "* Reordering reduced state matrix:" write (u, "(A)") allocate (state_ordered) call state_reduced%reorder_me (state_ordered) write (u, "(A)") "* Reduced and ordered state matrix:" call state_ordered%write (u) write (u, "(A)") "* Test output end: state_matrix_6" end subroutine state_matrix_7 @ %def state_matrix_7 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interactions} This module defines the [[interaction_t]] type. It is an extension of the [[state_matrix_t]] type. The state matrix is a representation of a multi-particle density matrix. It implements all possible flavor, color, and quantum-number assignments of the entries in a generic density matrix, and it can hold a complex matrix element for each entry. (Note that this matrix can hold non-diagonal entries in color and helicity space.) The [[interaction_t]] object associates this with a list of momenta, such that the whole object represents a multi-particle state. The [[interaction_t]] holds information about which particles are incoming, virtual (i.e., kept for the records), or outgoing. Each particle can be associated to a source within another interaction. This allows us to automatically fill those interaction momenta which have been computed or defined elsewhere. It also contains internal parent-child relations and flags for (virtual) particles which are to be treated as resonances. A quantum-number mask array summarizes, for each particle within the interaction, the treatment of flavor, color, or helicity (expose or ignore). A list of locks states which particles are bound to have an identical quantum-number mask. This is useful when the mask is changed at one place. <<[[interactions.f90]]>>= <> module interactions <> use io_units use diagnostics use sorting use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices <> <> <> <> contains <> end module interactions @ %def interactions @ Given a ordered list of quantum numbers (without any subtraction index) map these list to a state matrix, such that each list index corresponds to index of a set of quantum numbers in the state matrix, hence, the matrix element. The (unphysical) subtraction index is not a genuine quantum number and as such handled specially. <>= public :: qn_index_map_t <>= type :: qn_index_map_t private type(quantum_numbers_t), dimension(:, :), allocatable :: qn_flv type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel logical :: flip_hel = .false. integer :: n_flv = 0, n_hel = 0, n_sub = 0 integer, dimension(:, :, :), allocatable :: index contains <> end type qn_index_map_t @ %def qn_index_map_t @ Construct a mapping from interaction to an array of (sorted) quantum numbers. We strip all non-elementary particles (like beam) from the quantum numbers which we retrieve from the interaction. We consider helicity matrix elements only, when [[qn_hel]] is allocated. Else the helicity index is handled trivially as [[1]]. <>= generic :: init => qn_index_map_init procedure, private :: qn_index_map_init <>= subroutine qn_index_map_init (self, int, qn_flv, n_sub, qn_hel) class(qn_index_map_t), intent(out) :: self class(interaction_t), intent(in) :: int type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv integer, intent(in) :: n_sub type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel type(quantum_numbers_t), dimension(:), allocatable :: qn, qn_int integer :: i, i_flv, i_hel, i_sub self%qn_flv = qn_flv self%n_flv = size (qn_flv, dim=2) self%n_sub = n_sub if (present (qn_hel)) then if (size (qn_flv, dim=1) /= size (qn_hel, dim=1)) then call msg_bug ("[qn_index_map_init] number of particles does not match.") end if self%qn_hel = qn_hel self%n_hel = size (qn_hel, dim=2) else self%n_hel = 1 end if allocate (self%index (self%n_flv, self%n_hel, 0:self%n_sub), source=0) associate (n_me => int%get_n_matrix_elements ()) do i = 1, n_me qn_int = int%get_quantum_numbers (i, by_me_index = .true.) qn = pack (qn_int, qn_int%are_hard_process ()) i_flv = find_flv_index (self, qn) i_hel = 1; if (allocated (self%qn_hel)) & i_hel = find_hel_index (self, qn) i_sub = find_sub_index (self, qn) self%index(i_flv, i_hel, i_sub) = i end do end associate contains integer function find_flv_index (self, qn) result (i_flv) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j i_flv = 0 do j = 1, self%n_flv if (.not. all (qn .fmatch. self%qn_flv(:, j))) cycle i_flv = j exit end do if (i_flv < 1) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_message ("") call msg_message ("QN_FLV:") do j = 1, self%n_flv call quantum_numbers_write (self%qn_flv(:, j)) call msg_message ("") end do call msg_bug ("[find_flv_index] could not find flv in qn_flv.") end if end function find_flv_index integer function find_hel_index (self, qn) result (i_hel) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j i_hel = 0 do j = 1, self%n_hel if (.not. all (qn .hmatch. self%qn_hel(:, j))) cycle i_hel = j exit end do if (i_hel < 1) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_message ("") call msg_message ("QN_HEL:") do j = 1, self%n_hel call quantum_numbers_write (self%qn_hel(:, j)) call msg_message ("") end do call msg_bug ("[find_hel_index] could not find hel in qn_hel.") end if end function find_hel_index integer function find_sub_index (self, qn) result (i_sub) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: s i_sub = -1 do s = 0, self%n_sub if ((all (pack(qn%get_sub (), qn%get_sub () > 0) == s)) & .or. (all (qn%get_sub () == 0) .and. s == 0)) then i_sub = s exit end if end do if (i_sub < 0) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_bug ("[find_sub_index] could not find sub in qn.") end if end function find_sub_index end subroutine qn_index_map_init @ %def qn_index_map_init @ Construct a trivial mapping. <>= generic :: init => qn_index_map_init_trivial procedure, private :: qn_index_map_init_trivial <>= subroutine qn_index_map_init_trivial (self, int) class(qn_index_map_t), intent(out) :: self class(interaction_t), intent(in) :: int integer :: qn self%n_flv = int%get_n_matrix_elements () self%n_hel = 1 self%n_sub = 0 allocate (self%index(self%n_flv, self%n_hel, 0:self%n_sub), source = 0) do qn = 1, self%n_flv self%index(qn, 1, 0) = qn end do end subroutine qn_index_map_init_trivial @ %def qn_index_map_init_trivial @ Write the index map to unit. <>= procedure :: write => qn_index_map_write <>= subroutine qn_index_map_write (self, unit) class(qn_index_map_t), intent(in) :: self integer, intent(in), optional :: unit integer :: u, i_flv, i_hel, i_sub u = given_output_unit (unit); if (u < 0) return write (u, *) "flip_hel: ", self%flip_hel do i_flv = 1, self%n_flv if (allocated (self%qn_flv)) & call quantum_numbers_write (self%qn_flv(:, i_flv)) write (u, *) do i_hel = 1, self%n_hel if (allocated (self%qn_hel)) then call quantum_numbers_write (self%qn_hel(:, i_hel)) write (u, *) end if do i_sub = 0, self%n_sub write (u, *) & "(", i_flv, ",", i_hel, ",", i_sub, ") => ", self%index(i_flv, i_hel, i_sub) end do end do end do end subroutine qn_index_map_write @ %def qn_index_map_write @ Set helicity convention. If [[flip]], then we flip the helicities of anti-particles and we remap the indices accordingly. <>= procedure :: set_helicity_flip => qn_index_map_set_helicity_flip <>= subroutine qn_index_map_set_helicity_flip (self, yorn) class(qn_index_map_t), intent(inout) :: self logical, intent(in) :: yorn integer :: i, i_flv, i_hel, i_hel_new type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel_flip integer, dimension(:, :, :), allocatable :: index if (.not. allocated (self%qn_hel)) then call msg_bug ("[qn_index_map_set_helicity_flip] & &cannot flip not-given helicity.") end if ! Workaround for ifort (allocate-on-assignmet) allocate (qn_hel_flip (size (self%qn_hel, dim=1),& size (self%qn_hel, dim=2))) allocate (index (self%n_flv, self%n_hel, 0:self%n_sub),& source=self%index) self%flip_hel = yorn if (self%flip_hel) then do i_flv = 1, self%n_flv qn_hel_flip = self%qn_hel do i_hel = 1, self%n_hel do i = 1, size (self%qn_flv, dim=1) if (is_anti_particle (self%qn_flv(i, i_flv))) then call qn_hel_flip(i, i_hel)%flip_helicity () end if end do end do do i_hel = 1, self%n_hel i_hel_new = find_hel_index (qn_hel_flip, self%qn_hel(:, i_hel)) self%index(i_flv, i_hel_new, :) = index(i_flv, i_hel, :) end do end do end if contains logical function is_anti_particle (qn) result (yorn) type(quantum_numbers_t), intent(in) :: qn type(flavor_t) :: flv flv = qn%get_flavor () yorn = flv%get_pdg () < 0 end function is_anti_particle integer function find_hel_index (qn_sort, qn) result (i_hel) type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_sort type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j do j = 1, size(qn_sort, dim=2) if (.not. all (qn .hmatch. qn_sort(:, j))) cycle i_hel = j exit end do end function find_hel_index end subroutine qn_index_map_set_helicity_flip @ %def qn_index_map_set_helicity_flip @ Map from the previously given quantum number and subtraction index (latter ranging from 0 to [[n_sub]]) to the (interaction) matrix element. <>= procedure :: get_index => qn_index_map_get_index <>= integer function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index) class(qn_index_map_t), intent(in) :: self integer, intent(in) :: i_flv integer, intent(in), optional :: i_hel integer, intent(in), optional :: i_sub integer :: i_sub_opt, i_hel_opt - print *, "inside qn_index_map_get_index" i_sub_opt = 0; if (present (i_sub)) & i_sub_opt = i_sub i_hel_opt = 1; if (present (i_hel)) & i_hel_opt = i_hel index = 0 if (.not. allocated (self%index)) then call msg_bug ("[qn_index_map_get_index] The index map is not allocated.") end if index = self%index(i_flv, i_hel_opt, i_sub_opt) - print *, "index = ", index - call self%write () if (index <= 0) then call self%write () call msg_bug ("[qn_index_map_get_index] The index for the given quantum numbers could not be retrieved.") end if end function qn_index_map_get_index @ %def qn_index_map_get_i_flv @ Get [[n_flv]]. <>= procedure :: get_n_flv => qn_index_map_get_n_flv <>= integer function qn_index_map_get_n_flv (self) result (n_flv) class(qn_index_map_t), intent(in) :: self n_flv = self%n_flv end function qn_index_map_get_n_flv @ %def qn_index_map_get_n_flv @ Get [[n_hel]]. <>= procedure :: get_n_hel => qn_index_map_get_n_hel <>= integer function qn_index_map_get_n_hel (self) result (n_hel) class(qn_index_map_t), intent(in) :: self n_hel = self%n_hel end function qn_index_map_get_n_hel @ %def qn_index_map_get_n_flv @ Get [[n_sub]]. <>= procedure :: get_n_sub => qn_index_map_get_n_sub <>= integer function qn_index_map_get_n_sub (self) result (n_sub) class(qn_index_map_t), intent(in) :: self n_sub = self%n_sub end function qn_index_map_get_n_sub @ %def qn_index_map_get_n_sub @ \subsection{External interaction links} Each particle in an interaction can have a link to a corresponding particle in another interaction. This allows to fetch the momenta of incoming or virtual particles from the interaction where they are defined. The link object consists of a pointer to the interaction and an index. <>= type :: external_link_t private type(interaction_t), pointer :: int => null () integer :: i end type external_link_t @ %def external_link_t @ Set an external link. <>= subroutine external_link_set (link, int, i) type(external_link_t), intent(out) :: link type(interaction_t), target, intent(in) :: int integer, intent(in) :: i if (i /= 0) then link%int => int link%i = i end if end subroutine external_link_set @ %def external_link_set @ Reassign an external link to a new interaction (which should be an image of the original target). <>= subroutine external_link_reassign (link, int_src, int_target) type(external_link_t), intent(inout) :: link type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target if (associated (link%int)) then if (link%int%tag == int_src%tag) link%int => int_target end if end subroutine external_link_reassign @ %def external_link_reassign @ Return true if the link is set <>= function external_link_is_set (link) result (flag) logical :: flag type(external_link_t), intent(in) :: link flag = associated (link%int) end function external_link_is_set @ %def external_link_is_set @ Return the interaction pointer. <>= public :: external_link_get_ptr <>= function external_link_get_ptr (link) result (int) type(interaction_t), pointer :: int type(external_link_t), intent(in) :: link int => link%int end function external_link_get_ptr @ %def external_link_get_ptr @ Return the index within that interaction <>= public :: external_link_get_index <>= function external_link_get_index (link) result (i) integer :: i type(external_link_t), intent(in) :: link i = link%i end function external_link_get_index @ %def external_link_get_index @ Return a pointer to the momentum of the corresponding particle. If there is no association, return a null pointer. <>= function external_link_get_momentum_ptr (link) result (p) type(vector4_t), pointer :: p type(external_link_t), intent(in) :: link if (associated (link%int)) then p => link%int%p(link%i) else p => null () end if end function external_link_get_momentum_ptr @ %def external_link_get_momentum_ptr @ \subsection{Internal relations} In addition to the external links, particles within the interaction have parent-child relations. Here, more than one link is possible, and we set up an array. <>= type :: internal_link_list_t private integer :: length = 0 integer, dimension(:), allocatable :: link contains <> end type internal_link_list_t @ %def internal_link_t internal_link_list_t @ Output, non-advancing. <>= procedure :: write => internal_link_list_write <>= subroutine internal_link_list_write (object, unit) class(internal_link_list_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) do i = 1, object%length write (u, "(1x,I0)", advance="no") object%link(i) end do end subroutine internal_link_list_write @ %def internal_link_list_write @ Append an item. Start with an array size of 2 and double the size if necessary. Make sure that the indices are stored in ascending order. To this end, shift the existing entries right, starting from the end, as long as they are larger than the new entry. <>= procedure :: append => internal_link_list_append <>= subroutine internal_link_list_append (link_list, link) class(internal_link_list_t), intent(inout) :: link_list integer, intent(in) :: link integer :: l, j integer, dimension(:), allocatable :: tmp l = link_list%length if (allocated (link_list%link)) then if (l == size (link_list%link)) then allocate (tmp (2 * l)) tmp(:l) = link_list%link call move_alloc (from = tmp, to = link_list%link) end if else allocate (link_list%link (2)) end if link_list%link(l+1) = link SHIFT_LINK_IN_PLACE: do j = l, 1, -1 if (link >= link_list%link(j)) then exit SHIFT_LINK_IN_PLACE else link_list%link(j+1) = link_list%link(j) link_list%link(j) = link end if end do SHIFT_LINK_IN_PLACE link_list%length = l + 1 end subroutine internal_link_list_append @ %def internal_link_list_append @ Return true if the link list is nonempty: <>= procedure :: has_entries => internal_link_list_has_entries <>= function internal_link_list_has_entries (link_list) result (flag) class(internal_link_list_t), intent(in) :: link_list logical :: flag flag = link_list%length > 0 end function internal_link_list_has_entries @ %def internal_link_list_has_entries @ Return the list length <>= procedure :: get_length => internal_link_list_get_length <>= function internal_link_list_get_length (link_list) result (length) class(internal_link_list_t), intent(in) :: link_list integer :: length length = link_list%length end function internal_link_list_get_length @ %def internal_link_list_get_length @ Return an entry. <>= procedure :: get_link => internal_link_list_get_link <>= function internal_link_list_get_link (link_list, i) result (link) class(internal_link_list_t), intent(in) :: link_list integer, intent(in) :: i integer :: link if (i <= link_list%length) then link = link_list%link(i) else call msg_bug ("Internal link list: out of bounds") end if end function internal_link_list_get_link @ %def internal_link_list_get_link @ \subsection{The interaction type} An interaction is an entangled system of particles. Thus, the interaction object consists of two parts: the subevent, and the quantum state which technically is a trie. The subnode levels beyond the trie root node are in correspondence to the subevent, so both should be traversed in parallel. The subevent is implemented as an allocatable array of four-momenta. The first [[n_in]] particles are incoming, [[n_vir]] particles in-between can be kept for bookkeeping, and the last [[n_out]] particles are outgoing. Distinct interactions are linked by their particles: for each particle, we have the possibility of links to corresponding particles in other interactions. Furthermore, for bookkeeping purposes we have a self-link array [[relations]] where the parent-child relations are kept, and a flag array [[resonant]] which is set for an intermediate resonance. Each momentum is associated with masks for flavor, color, and helicity. If a mask entry is set, the associated quantum number is to be ignored for that particle. If any mask has changed, the flag [[update]] is set. We can have particle pairs locked together. If this is the case, the corresponding mask entries are bound to be equal. This is useful for particles that go through the interaction. The interaction tag serves bookkeeping purposes. In particular, it identifies links in printout. <>= public :: interaction_t <>= type :: interaction_t private integer :: tag = 0 type(state_matrix_t) :: state_matrix integer :: n_in = 0 integer :: n_vir = 0 integer :: n_out = 0 integer :: n_tot = 0 logical, dimension(:), allocatable :: p_is_known type(vector4_t), dimension(:), allocatable :: p type(external_link_t), dimension(:), allocatable :: source type(internal_link_list_t), dimension(:), allocatable :: parents type(internal_link_list_t), dimension(:), allocatable :: children logical, dimension(:), allocatable :: resonant type(quantum_numbers_mask_t), dimension(:), allocatable :: mask integer, dimension(:), allocatable :: hel_lock logical :: update_state_matrix = .false. logical :: update_values = .false. contains <> end type interaction_t @ %def interaction_particle_p interaction_t @ Initialize the particle array with a fixed size. The first [[n_in]] particles are incoming, the rest outgoing. Masks are optional. There is also an optional tag. The interaction still needs fixing the values, but that is to be done after all branches have been added. Interaction tags are assigned consecutively, using a [[save]]d variable local to this procedure. If desired, we can provide a seed for the interaction tags. Such a seed should be positive. The default seed is one. [[tag=0]] indicates an empty interaction. If [[set_relations]] is set and true, we establish parent-child relations for all incoming and outgoing particles. Virtual particles are skipped; this option is normally used only for interations without virtual particles. <>= procedure :: basic_init => interaction_init <>= subroutine interaction_init & (int, n_in, n_vir, n_out, & tag, resonant, mask, hel_lock, set_relations, store_values) class(interaction_t), intent(out) :: int integer, intent(in) :: n_in, n_vir, n_out integer, intent(in), optional :: tag logical, dimension(:), intent(in), optional :: resonant type(quantum_numbers_mask_t), dimension(:), intent(in), optional :: mask integer, dimension(:), intent(in), optional :: hel_lock logical, intent(in), optional :: set_relations, store_values logical :: set_rel integer :: i, j set_rel = .false.; if (present (set_relations)) set_rel = set_relations call interaction_set_tag (int, tag) call int%state_matrix%init (store_values) int%n_in = n_in int%n_vir = n_vir int%n_out = n_out int%n_tot = n_in + n_vir + n_out allocate (int%p_is_known (int%n_tot)) int%p_is_known = .false. allocate (int%p (int%n_tot)) allocate (int%source (int%n_tot)) allocate (int%parents (int%n_tot)) allocate (int%children (int%n_tot)) allocate (int%resonant (int%n_tot)) if (present (resonant)) then int%resonant = resonant else int%resonant = .false. end if allocate (int%mask (int%n_tot)) allocate (int%hel_lock (int%n_tot)) if (present (mask)) then int%mask = mask end if if (present (hel_lock)) then int%hel_lock = hel_lock else int%hel_lock = 0 end if int%update_state_matrix = .false. int%update_values = .true. if (set_rel) then do i = 1, n_in do j = 1, n_out call int%relate (i, n_in + j) end do end do end if end subroutine interaction_init @ %def interaction_init @ Set or create a unique tag for the interaction. Without interaction, reset the tag counter. <>= subroutine interaction_set_tag (int, tag) type(interaction_t), intent(inout), optional :: int integer, intent(in), optional :: tag integer, save :: stored_tag = 1 if (present (int)) then if (present (tag)) then int%tag = tag else int%tag = stored_tag stored_tag = stored_tag + 1 end if else if (present (tag)) then stored_tag = tag else stored_tag = 1 end if end subroutine interaction_set_tag @ %def interaction_set_tag @ The public interface for the previous procedure only covers the reset functionality. <>= public :: reset_interaction_counter <>= subroutine reset_interaction_counter (tag) integer, intent(in), optional :: tag call interaction_set_tag (tag=tag) end subroutine reset_interaction_counter @ %def reset_interaction_counter @ Finalizer: The state-matrix object contains pointers. <>= procedure :: final => interaction_final <>= subroutine interaction_final (object) class(interaction_t), intent(inout) :: object call object%state_matrix%final () end subroutine interaction_final @ %def interaction_final @ Output. The [[verbose]] option refers to the state matrix output. <>= procedure :: basic_write => interaction_write <>= subroutine interaction_write & (int, unit, verbose, show_momentum_sum, show_mass, show_state, & col_verbose, testflag) class(interaction_t), intent(in) :: int integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: show_state, col_verbose, testflag integer :: u integer :: i, index_link type(interaction_t), pointer :: int_link logical :: show_st u = given_output_unit (unit); if (u < 0) return show_st = .true.; if (present (show_state)) show_st = show_state if (int%tag /= 0) then write (u, "(1x,A,I0)") "Interaction: ", int%tag do i = 1, int%n_tot if (i == 1 .and. int%n_in > 0) then write (u, "(1x,A)") "Incoming:" else if (i == int%n_in + 1 .and. int%n_vir > 0) then write (u, "(1x,A)") "Virtual:" else if (i == int%n_in + int%n_vir + 1 .and. int%n_out > 0) then write (u, "(1x,A)") "Outgoing:" end if write (u, "(1x,A,1x,I0)", advance="no") "Particle", i if (allocated (int%resonant)) then if (int%resonant(i)) then write (u, "(A)") "[r]" else write (u, *) end if else write (u, *) end if if (allocated (int%p)) then if (int%p_is_known(i)) then call vector4_write (int%p(i), u, show_mass, testflag) else write (u, "(A)") " [momentum undefined]" end if else write (u, "(A)") " [momentum not allocated]" end if if (allocated (int%mask)) then write (u, "(1x,A)", advance="no") "mask [fch] = " call int%mask(i)%write (u) write (u, *) end if if (int%parents(i)%has_entries () & .or. int%children(i)%has_entries ()) then write (u, "(1x,A)", advance="no") "internal links:" call int%parents(i)%write (u) if (int%parents(i)%has_entries ()) & write (u, "(1x,A)", advance="no") "=>" write (u, "(1x,A)", advance="no") "X" if (int%children(i)%has_entries ()) & write (u, "(1x,A)", advance="no") "=>" call int%children(i)%write (u) write (u, *) end if if (allocated (int%hel_lock)) then if (int%hel_lock(i) /= 0) then write (u, "(1x,A,1x,I0)") "helicity lock:", int%hel_lock(i) end if end if if (external_link_is_set (int%source(i))) then write (u, "(1x,A)", advance="no") "source:" int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) write (u, "(1x,'(',I0,')',I0)", advance="no") & int_link%tag, index_link write (u, *) end if end do if (present (show_momentum_sum)) then if (allocated (int%p) .and. show_momentum_sum) then write (u, "(1x,A)") "Incoming particles (sum):" call vector4_write & (sum (int%p(1 : int%n_in)), u, show_mass = show_mass) write (u, "(1x,A)") "Outgoing particles (sum):" call vector4_write & (sum (int%p(int%n_in + int%n_vir + 1 : )), & u, show_mass = show_mass) write (u, *) end if end if if (show_st) then call int%write_state_matrix (write_value_list = verbose, & verbose = verbose, unit = unit, col_verbose = col_verbose, & testflag = testflag) end if else write (u, "(1x,A)") "Interaction: [empty]" end if end subroutine interaction_write @ %def interaction_write @ <>= procedure :: write_state_matrix => interaction_write_state_matrix <>= subroutine interaction_write_state_matrix (int, unit, write_value_list, & verbose, col_verbose, testflag) class(interaction_t), intent(in) :: int logical, intent(in), optional :: write_value_list, verbose, col_verbose logical, intent(in), optional :: testflag integer, intent(in), optional :: unit call int%state_matrix%write (write_value_list = verbose, & verbose = verbose, unit = unit, col_verbose = col_verbose, & testflag = testflag) end subroutine interaction_write_state_matrix @ %def interaction_write_state_matrix @ Reduce the [[state_matrix]] over the quantum mask. During the reduce procedure the iterator does not conserve the order of the matrix element respective their quantum numbers. Setting the [[keep_order]] results in a reorder state matrix with reintroduced matrix element indices. <>= procedure :: reduce_state_matrix => interaction_reduce_state_matrix <>= subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order) class(interaction_t), intent(inout) :: int type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask logical, optional, intent(in) :: keep_order type(state_matrix_t) :: state logical :: opt_keep_order opt_keep_order = .false. if (present (keep_order)) opt_keep_order = keep_order call int%state_matrix%reduce (qn_mask, state, keep_me_index = keep_order) int%state_matrix = state if (opt_keep_order) then call int%state_matrix%reorder_me (state) int%state_matrix = state end if end subroutine interaction_reduce_state_matrix @ %def interaction_reduce_state_matrix @ Assignment: We implement this as a deep copy. This applies, in particular, to the state-matrix and internal-link components. Furthermore, the new interaction acquires a new tag. <>= public :: assignment(=) <>= interface assignment(=) module procedure interaction_assign end interface <>= subroutine interaction_assign (int_out, int_in) type(interaction_t), intent(out) :: int_out type(interaction_t), intent(in), target :: int_in call interaction_set_tag (int_out) int_out%state_matrix = int_in%state_matrix int_out%n_in = int_in%n_in int_out%n_out = int_in%n_out int_out%n_vir = int_in%n_vir int_out%n_tot = int_in%n_tot if (allocated (int_in%p_is_known)) then allocate (int_out%p_is_known (size (int_in%p_is_known))) int_out%p_is_known = int_in%p_is_known end if if (allocated (int_in%p)) then allocate (int_out%p (size (int_in%p))) int_out%p = int_in%p end if if (allocated (int_in%source)) then allocate (int_out%source (size (int_in%source))) int_out%source = int_in%source end if if (allocated (int_in%parents)) then allocate (int_out%parents (size (int_in%parents))) int_out%parents = int_in%parents end if if (allocated (int_in%children)) then allocate (int_out%children (size (int_in%children))) int_out%children = int_in%children end if if (allocated (int_in%resonant)) then allocate (int_out%resonant (size (int_in%resonant))) int_out%resonant = int_in%resonant end if if (allocated (int_in%mask)) then allocate (int_out%mask (size (int_in%mask))) int_out%mask = int_in%mask end if if (allocated (int_in%hel_lock)) then allocate (int_out%hel_lock (size (int_in%hel_lock))) int_out%hel_lock = int_in%hel_lock end if int_out%update_state_matrix = int_in%update_state_matrix int_out%update_values = int_in%update_values end subroutine interaction_assign @ %def interaction_assign @ \subsection{Methods inherited from the state matrix member} Until F2003 is standard, we cannot implement inheritance directly. Therefore, we need wrappers for ``inherited'' methods. Make a new branch in the state matrix if it does not yet exist. This is not just a wrapper but it introduces the interaction mask: where a quantum number is masked, it is not transferred but set undefined. After this, the value array has to be updated. <>= procedure :: add_state => interaction_add_state <>= subroutine interaction_add_state & (int, qn, index, value, sum_values, counter_index, ignore_sub, me_index) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: index complex(default), intent(in), optional :: value logical, intent(in), optional :: sum_values integer, intent(in), optional :: counter_index logical, intent(in), optional :: ignore_sub integer, intent(out), optional :: me_index type(quantum_numbers_t), dimension(size(qn)) :: qn_tmp qn_tmp = qn call qn_tmp%undefine (int%mask) call int%state_matrix%add_state (qn_tmp, index, value, sum_values, & counter_index, ignore_sub, me_index) int%update_values = .true. end subroutine interaction_add_state @ %def interaction_add_state @ Freeze the quantum state: First collapse the quantum state, i.e., remove quantum numbers if any mask has changed, then fix the array of value pointers. <>= procedure :: freeze => interaction_freeze <>= subroutine interaction_freeze (int) class(interaction_t), intent(inout) :: int if (int%update_state_matrix) then call int%state_matrix%collapse (int%mask) int%update_state_matrix = .false. int%update_values = .true. end if if (int%update_values) then call int%state_matrix%freeze () int%update_values = .false. end if end subroutine interaction_freeze @ %def interaction_freeze @ Return true if the state matrix is empty. <>= procedure :: is_empty => interaction_is_empty <>= pure function interaction_is_empty (int) result (flag) logical :: flag class(interaction_t), intent(in) :: int flag = int%state_matrix%is_empty () end function interaction_is_empty @ %def interaction_is_empty @ Get the number of values stored in the state matrix: <>= procedure :: get_n_matrix_elements => & interaction_get_n_matrix_elements <>= pure function interaction_get_n_matrix_elements (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_n_matrix_elements () end function interaction_get_n_matrix_elements @ %def interaction_get_n_matrix_elements @ <>= procedure :: get_state_depth => interaction_get_state_depth <>= function interaction_get_state_depth (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_depth () end function interaction_get_state_depth @ %def interaction_get_state_depth @ <>= procedure :: get_n_in_helicities => interaction_get_n_in_helicities <>= function interaction_get_n_in_helicities (int) result (n_hel) integer :: n_hel class(interaction_t), intent(in) :: int type(interaction_t) :: int_copy type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(quantum_numbers_t), dimension(:,:), allocatable :: qn integer :: i allocate (qn_mask (int%n_tot)) do i = 1, int%n_tot if (i <= int%n_in) then call qn_mask(i)%init (.true., .true., .false.) else call qn_mask(i)%init (.true., .true., .true.) end if end do int_copy = int call int_copy%set_mask (qn_mask) call int_copy%freeze () allocate (qn (int_copy%state_matrix%get_n_matrix_elements (), & int_copy%state_matrix%get_depth ())) qn = int_copy%get_quantum_numbers () n_hel = 0 do i = 1, size (qn, dim=1) if (all (qn(i,:)%get_subtraction_index () == 0)) n_hel = n_hel + 1 end do call int_copy%final () deallocate (qn_mask) deallocate (qn) end function interaction_get_n_in_helicities @ %def interaction_get_n_in_helicities @ Get the size of the [[me]]-array of the associated state matrix for debugging purposes <>= procedure :: get_me_size => interaction_get_me_size <>= pure function interaction_get_me_size (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_me_size () end function interaction_get_me_size @ %def interaction_get_me_size @ Get the norm of the state matrix (if the norm has been taken out, otherwise this would be unity). <>= procedure :: get_norm => interaction_get_norm <>= pure function interaction_get_norm (int) result (norm) real(default) :: norm class(interaction_t), intent(in) :: int norm = int%state_matrix%get_norm () end function interaction_get_norm @ %def interaction_get_norm @ <>= procedure :: get_n_sub => interaction_get_n_sub <>= function interaction_get_n_sub (int) result (n_sub) integer :: n_sub class(interaction_t), intent(in) :: int n_sub = int%state_matrix%get_n_sub () end function interaction_get_n_sub @ %def interaction_get_n_sub @ Get the quantum number array that corresponds to a given index. <>= generic :: get_quantum_numbers => get_quantum_numbers_single, & get_quantum_numbers_all, & get_quantum_numbers_all_qn_mask procedure :: get_quantum_numbers_single => & interaction_get_quantum_numbers_single procedure :: get_quantum_numbers_all => & interaction_get_quantum_numbers_all procedure :: get_quantum_numbers_all_qn_mask => & interaction_get_quantum_numbers_all_qn_mask <>= function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn) type(quantum_numbers_t), dimension(:), allocatable :: qn class(interaction_t), intent(in), target :: int integer, intent(in) :: i logical, intent(in), optional :: by_me_index allocate (qn (int%state_matrix%get_depth ())) qn = int%state_matrix%get_quantum_number (i, by_me_index) end function interaction_get_quantum_numbers_single function interaction_get_quantum_numbers_all (int) result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(interaction_t), intent(in), target :: int integer :: i <> <>= allocate (qn (int%state_matrix%get_n_matrix_elements (), & int%state_matrix%get_depth())) do i = 1, int%state_matrix%get_n_matrix_elements () qn (i, :) = int%state_matrix%get_quantum_number (i) end do <>= end function interaction_get_quantum_numbers_all function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) & result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), intent(in) :: qn_mask integer :: n_redundant, n_all, n_me integer :: i type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all <> <>= call int%state_matrix%get_quantum_numbers (qn_all) n_redundant = count (qn_all%are_redundant (qn_mask)) n_all = size (qn_all) !!! Number of matrix elements = survivors / n_particles n_me = (n_all - n_redundant) / int%state_matrix%get_depth () allocate (qn (n_me, int%state_matrix%get_depth())) do i = 1, n_me if (.not. any (qn_all(i, :)%are_redundant (qn_mask))) & qn (i, :) = qn_all (i, :) end do <>= end function interaction_get_quantum_numbers_all_qn_mask @ %def interaction_get_quantum_numbers_single @ %def interaction_get_quantum_numbers_all @ %def interaction_get_quantum_numbers_all_qn_mask @ @ <>= procedure :: get_quantum_numbers_all_sub => interaction_get_quantum_numbers_all_sub <>= subroutine interaction_get_quantum_numbers_all_sub (int, qn) class(interaction_t), intent(in) :: int type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn integer :: i <> end subroutine interaction_get_quantum_numbers_all_sub @ %def interaction_get_quantum_numbers_all @ <>= procedure :: get_flavors => interaction_get_flavors <>= subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv) class(interaction_t), intent(in), target :: int logical, intent(in) :: only_elementary type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask integer, intent(out), dimension(:,:), allocatable :: flv call int%state_matrix%get_flavors (only_elementary, qn_mask, flv) end subroutine interaction_get_flavors @ %def interaction_get_flavors @ <>= procedure :: get_quantum_numbers_mask => interaction_get_quantum_numbers_mask <>= subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn) class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), intent(in) :: qn_mask type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn integer :: n_redundant, n_all, n_me integer :: i type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all <> end subroutine interaction_get_quantum_numbers_mask @ %def interaction_get_quantum_numbers_mask @ Get the matrix element that corresponds to a set of quantum numbers, a given index, or return the whole array. <>= generic :: get_matrix_element => get_matrix_element_single generic :: get_matrix_element => get_matrix_element_array procedure :: get_matrix_element_single => & interaction_get_matrix_element_single procedure :: get_matrix_element_array => & interaction_get_matrix_element_array <>= elemental function interaction_get_matrix_element_single (int, i) result (me) complex(default) :: me class(interaction_t), intent(in) :: int integer, intent(in) :: i me = int%state_matrix%get_matrix_element (i) end function interaction_get_matrix_element_single @ %def interaction_get_matrix_element_single <>= function interaction_get_matrix_element_array (int) result (me) complex(default), dimension(:), allocatable :: me class(interaction_t), intent(in) :: int allocate (me (int%get_n_matrix_elements ())) me = int%state_matrix%get_matrix_element () end function interaction_get_matrix_element_array @ %def interaction_get_matrix_element_array @ Set the complex value(s) stored in the quantum state. <>= generic :: set_matrix_element => interaction_set_matrix_element_qn, & interaction_set_matrix_element_all, & interaction_set_matrix_element_array, & interaction_set_matrix_element_single, & interaction_set_matrix_element_clone procedure :: interaction_set_matrix_element_qn procedure :: interaction_set_matrix_element_all procedure :: interaction_set_matrix_element_array procedure :: interaction_set_matrix_element_single procedure :: interaction_set_matrix_element_clone @ %def interaction_set_matrix_element @ Indirect access via the quantum number array: <>= subroutine interaction_set_matrix_element_qn (int, qn, val) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: val call int%state_matrix%set_matrix_element (qn, val) end subroutine interaction_set_matrix_element_qn @ %def interaction_set_matrix_element @ Set all entries of the matrix-element array to a given value. <>= subroutine interaction_set_matrix_element_all (int, value) class(interaction_t), intent(inout) :: int complex(default), intent(in) :: value call int%state_matrix%set_matrix_element (value) end subroutine interaction_set_matrix_element_all @ %def interaction_set_matrix_element_all @ Set the matrix-element array directly. <>= subroutine interaction_set_matrix_element_array (int, value, range) class(interaction_t), intent(inout) :: int complex(default), intent(in), dimension(:) :: value integer, intent(in), dimension(:), optional :: range call int%state_matrix%set_matrix_element (value, range) end subroutine interaction_set_matrix_element_array pure subroutine interaction_set_matrix_element_single (int, i, value) class(interaction_t), intent(inout) :: int integer, intent(in) :: i complex(default), intent(in) :: value call int%state_matrix%set_matrix_element (i, value) end subroutine interaction_set_matrix_element_single @ %def interaction_set_matrix_element_array @ %def interaction_set_matrix_element_single @ Clone from another (matching) interaction. <>= subroutine interaction_set_matrix_element_clone (int, int1) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in) :: int1 call int%state_matrix%set_matrix_element (int1%state_matrix) end subroutine interaction_set_matrix_element_clone @ %def interaction_set_matrix_element_clone @ <>= procedure :: set_only_matrix_element => interaction_set_only_matrix_element <>= subroutine interaction_set_only_matrix_element (int, i, value) class(interaction_t), intent(inout) :: int integer, intent(in) :: i complex(default), intent(in) :: value call int%set_matrix_element (cmplx (0, 0, default)) call int%set_matrix_element (i, value) end subroutine interaction_set_only_matrix_element @ %def interaction_set_only_matrix_element @ <>= procedure :: add_to_matrix_element => interaction_add_to_matrix_element <>= subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value logical, intent(in), optional :: match_only_flavor call int%state_matrix%add_to_matrix_element (qn, value, match_only_flavor) end subroutine interaction_add_to_matrix_element @ %def interaction_add_to_matrix_element @ Get the indices of any diagonal matrix elements. <>= procedure :: get_diagonal_entries => interaction_get_diagonal_entries <>= subroutine interaction_get_diagonal_entries (int, i) class(interaction_t), intent(in) :: int integer, dimension(:), allocatable, intent(out) :: i call int%state_matrix%get_diagonal_entries (i) end subroutine interaction_get_diagonal_entries @ %def interaction_get_diagonal_entries @ Renormalize the state matrix by its trace, if nonzero. The renormalization is reflected in the state-matrix norm. <>= procedure :: normalize_by_trace => interaction_normalize_by_trace <>= subroutine interaction_normalize_by_trace (int) class(interaction_t), intent(inout) :: int call int%state_matrix%normalize_by_trace () end subroutine interaction_normalize_by_trace @ %def interaction_normalize_by_trace @ Analogous, but renormalize by maximal (absolute) value. <>= procedure :: normalize_by_max => interaction_normalize_by_max <>= subroutine interaction_normalize_by_max (int) class(interaction_t), intent(inout) :: int call int%state_matrix%normalize_by_max () end subroutine interaction_normalize_by_max @ %def interaction_normalize_by_max @ Explicitly set the norm value (of the state matrix). <>= procedure :: set_norm => interaction_set_norm <>= subroutine interaction_set_norm (int, norm) class(interaction_t), intent(inout) :: int real(default), intent(in) :: norm call int%state_matrix%set_norm (norm) end subroutine interaction_set_norm @ %def interaction_set_norm @ <>= procedure :: set_state_matrix => interaction_set_state_matrix <>= subroutine interaction_set_state_matrix (int, state) class(interaction_t), intent(inout) :: int type(state_matrix_t), intent(in) :: state int%state_matrix = state end subroutine interaction_set_state_matrix @ %def interaction_set_state_matrix @ Return the maximum absolute value of color indices. <>= procedure :: get_max_color_value => & interaction_get_max_color_value <>= function interaction_get_max_color_value (int) result (cmax) class(interaction_t), intent(in) :: int integer :: cmax cmax = int%state_matrix%get_max_color_value () end function interaction_get_max_color_value @ %def interaction_get_max_color_value @ Factorize the state matrix into single-particle state matrices, the branch selection depending on a (random) value between 0 and 1; optionally also return a correlated state matrix. <>= procedure :: factorize => interaction_factorize <>= subroutine interaction_factorize & (int, mode, x, ok, single_state, correlated_state, qn_in) class(interaction_t), intent(in), target :: int integer, intent(in) :: mode real(default), intent(in) :: x logical, intent(out) :: ok type(state_matrix_t), & dimension(:), allocatable, intent(out) :: single_state type(state_matrix_t), intent(out), optional :: correlated_state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in call int%state_matrix%factorize & (mode, x, ok, single_state, correlated_state, qn_in) end subroutine interaction_factorize @ %def interaction_factorize @ Sum all matrix element values <>= procedure :: sum => interaction_sum <>= function interaction_sum (int) result (value) class(interaction_t), intent(in) :: int complex(default) :: value value = int%state_matrix%sum () end function interaction_sum @ %def interaction_sum @ Append new states which are color-contracted versions of the existing states. The matrix element index of each color contraction coincides with the index of its origin, so no new matrix elements are generated. After this operation, no [[freeze]] must be performed anymore. <>= procedure :: add_color_contractions => & interaction_add_color_contractions <>= subroutine interaction_add_color_contractions (int) class(interaction_t), intent(inout) :: int call int%state_matrix%add_color_contractions () end subroutine interaction_add_color_contractions @ %def interaction_add_color_contractions @ Multiply matrix elements from two interactions. Choose the elements as given by the integer index arrays, multiply them and store the sum of products in the indicated matrix element. The suffixes mean: c=conjugate first factor; f=include weighting factor. <>= procedure :: evaluate_product => interaction_evaluate_product procedure :: evaluate_product_cf => interaction_evaluate_product_cf procedure :: evaluate_square_c => interaction_evaluate_square_c procedure :: evaluate_sum => interaction_evaluate_sum procedure :: evaluate_me_sum => interaction_evaluate_me_sum <>= pure subroutine interaction_evaluate_product & (int, i, int1, int2, index1, index2) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1, int2 integer, dimension(:), intent(in) :: index1, index2 call int%state_matrix%evaluate_product & (i, int1%state_matrix, int2%state_matrix, & index1, index2) end subroutine interaction_evaluate_product pure subroutine interaction_evaluate_product_cf & (int, i, int1, int2, index1, index2, factor) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1, int2 integer, dimension(:), intent(in) :: index1, index2 complex(default), dimension(:), intent(in) :: factor call int%state_matrix%evaluate_product_cf & (i, int1%state_matrix, int2%state_matrix, & index1, index2, factor) end subroutine interaction_evaluate_product_cf pure subroutine interaction_evaluate_square_c (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_square_c (i, int1%state_matrix, index1) end subroutine interaction_evaluate_square_c pure subroutine interaction_evaluate_sum (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_sum (i, int1%state_matrix, index1) end subroutine interaction_evaluate_sum pure subroutine interaction_evaluate_me_sum (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_me_sum (i, int1%state_matrix, index1) end subroutine interaction_evaluate_me_sum @ %def interaction_evaluate_product @ %def interaction_evaluate_product_cf @ %def interaction_evaluate_square_c @ %def interaction_evaluate_sum @ %def interaction_evaluate_me_sum @ Tag quantum numbers of the state matrix als part of the hard process, according to the indices specified in [[tag]]. If no [[tag]] is given, all quantum numbers are tagged as part of the hard process. <>= procedure :: tag_hard_process => interaction_tag_hard_process <>= subroutine interaction_tag_hard_process (int, tag) class(interaction_t), intent(inout) :: int integer, dimension(:), intent(in), optional :: tag type(state_matrix_t) :: state call int%state_matrix%tag_hard_process (state, tag) call int%state_matrix%final () int%state_matrix = state end subroutine interaction_tag_hard_process @ %def interaction_tag_hard_process \subsection{Accessing contents} Return the integer tag. <>= procedure :: get_tag => interaction_get_tag <>= function interaction_get_tag (int) result (tag) class(interaction_t), intent(in) :: int integer :: tag tag = int%tag end function interaction_get_tag @ %def interaction_get_tag @ Return the number of particles. <>= procedure :: get_n_tot => interaction_get_n_tot procedure :: get_n_in => interaction_get_n_in procedure :: get_n_vir => interaction_get_n_vir procedure :: get_n_out => interaction_get_n_out <>= pure function interaction_get_n_tot (object) result (n_tot) class(interaction_t), intent(in) :: object integer :: n_tot n_tot = object%n_tot end function interaction_get_n_tot pure function interaction_get_n_in (object) result (n_in) class(interaction_t), intent(in) :: object integer :: n_in n_in = object%n_in end function interaction_get_n_in pure function interaction_get_n_vir (object) result (n_vir) class(interaction_t), intent(in) :: object integer :: n_vir n_vir = object%n_vir end function interaction_get_n_vir pure function interaction_get_n_out (object) result (n_out) class(interaction_t), intent(in) :: object integer :: n_out n_out = object%n_out end function interaction_get_n_out @ %def interaction_get_n_tot @ %def interaction_get_n_in interaction_get_n_vir interaction_get_n_out @ Return a momentum index. The flags specify whether to keep/drop incoming, virtual, or outgoing momenta. Check for illegal values. <>= function idx (int, i, outgoing) integer :: idx type(interaction_t), intent(in) :: int integer, intent(in) :: i logical, intent(in), optional :: outgoing logical :: in, vir, out if (present (outgoing)) then in = .not. outgoing vir = .false. out = outgoing else in = .true. vir = .true. out = .true. end if idx = 0 if (in) then if (vir) then if (out) then if (i <= int%n_tot) idx = i else if (i <= int%n_in + int%n_vir) idx = i end if else if (out) then if (i <= int%n_in) then idx = i else if (i <= int%n_in + int%n_out) then idx = int%n_vir + i end if else if (i <= int%n_in) idx = i end if else if (vir) then if (out) then if (i <= int%n_vir + int%n_out) idx = int%n_in + i else if (i <= int%n_vir) idx = int%n_in + i end if else if (out) then if (i <= int%n_out) idx = int%n_in + int%n_vir + i end if if (idx == 0) then call int%basic_write () print *, i, in, vir, out call msg_bug (" Momentum index is out of range for this interaction") end if end function idx @ %def idx @ Return all or just a specific four-momentum. <>= generic :: get_momenta => get_momenta_all, get_momenta_idx procedure :: get_momentum => interaction_get_momentum procedure :: get_momenta_all => interaction_get_momenta_all procedure :: get_momenta_idx => interaction_get_momenta_idx <>= function interaction_get_momenta_all (int, outgoing) result (p) class(interaction_t), intent(in) :: int type(vector4_t), dimension(:), allocatable :: p logical, intent(in), optional :: outgoing integer :: i if (present (outgoing)) then if (outgoing) then allocate (p (int%n_out)) else allocate (p (int%n_in)) end if else allocate (p (int%n_tot)) end if do i = 1, size (p) p(i) = int%p(idx (int, i, outgoing)) end do end function interaction_get_momenta_all function interaction_get_momenta_idx (int, jj) result (p) class(interaction_t), intent(in) :: int type(vector4_t), dimension(:), allocatable :: p integer, dimension(:), intent(in) :: jj allocate (p (size (jj))) p = int%p(jj) end function interaction_get_momenta_idx function interaction_get_momentum (int, i, outgoing) result (p) class(interaction_t), intent(in) :: int type(vector4_t) :: p integer, intent(in) :: i logical, intent(in), optional :: outgoing p = int%p(idx (int, i, outgoing)) end function interaction_get_momentum @ %def interaction_get_momenta interaction_get_momentum @ This is a variant as a subroutine. Redundant, but the function above fails at times for gfortran 4.5.0 (double allocation, compiler bug). <>= procedure :: get_momenta_sub => interaction_get_momenta_sub <>= subroutine interaction_get_momenta_sub (int, p, outgoing) class(interaction_t), intent(in) :: int type(vector4_t), dimension(:), intent(out) :: p logical, intent(in), optional :: outgoing integer :: i do i = 1, size (p) p(i) = int%p(idx (int, i, outgoing)) end do end subroutine interaction_get_momenta_sub @ %def interaction_get_momenta_sub @ Return a shallow copy of the state matrix: <>= procedure :: get_state_matrix_ptr => & interaction_get_state_matrix_ptr <>= function interaction_get_state_matrix_ptr (int) result (state) class(interaction_t), intent(in), target :: int type(state_matrix_t), pointer :: state state => int%state_matrix end function interaction_get_state_matrix_ptr @ %def interaction_get_state_matrix_ptr @ Return the array of resonance flags <>= procedure :: get_resonance_flags => interaction_get_resonance_flags <>= function interaction_get_resonance_flags (int) result (resonant) class(interaction_t), intent(in) :: int logical, dimension(size(int%resonant)) :: resonant resonant = int%resonant end function interaction_get_resonance_flags @ %def interaction_get_resonance_flags @ Return the quantum-numbers mask (or part of it) <>= generic :: get_mask => get_mask_all, get_mask_slice procedure :: get_mask_all => interaction_get_mask_all procedure :: get_mask_slice => interaction_get_mask_slice <>= function interaction_get_mask_all (int) result (mask) class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), dimension(size(int%mask)) :: mask mask = int%mask end function interaction_get_mask_all function interaction_get_mask_slice (int, index) result (mask) class(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: index type(quantum_numbers_mask_t), dimension(size(index)) :: mask mask = int%mask(index) end function interaction_get_mask_slice @ %def interaction_get_mask @ Compute the invariant mass squared of the incoming particles (if any, otherwise outgoing). <>= public :: interaction_get_s <>= function interaction_get_s (int) result (s) real(default) :: s type(interaction_t), intent(in) :: int if (int%n_in /= 0) then s = sum (int%p(:int%n_in)) ** 2 else s = sum (int%p(int%n_vir + 1 : )) ** 2 end if end function interaction_get_s @ %def interaction_get_s @ Compute the Lorentz transformation that transforms the incoming particles from the center-of-mass frame to the lab frame where they are given. If the c.m. mass squared is negative or zero, return the identity. <>= public :: interaction_get_cm_transformation <>= function interaction_get_cm_transformation (int) result (lt) type(lorentz_transformation_t) :: lt type(interaction_t), intent(in) :: int type(vector4_t) :: p_cm real(default) :: s if (int%n_in /= 0) then p_cm = sum (int%p(:int%n_in)) else p_cm = sum (int%p(int%n_vir+1:)) end if s = p_cm ** 2 if (s > 0) then lt = boost (p_cm, sqrt (s)) else lt = identity end if end function interaction_get_cm_transformation @ %def interaction_get_cm_transformation @ Return flavor, momentum, and position of the first outgoing unstable particle present in the interaction. Note that we need not iterate through the state matrix; if there is an unstable particle, it will be present in all state-matrix entries. <>= public :: interaction_get_unstable_particle <>= subroutine interaction_get_unstable_particle (int, flv, p, i) type(interaction_t), intent(in), target :: int type(flavor_t), intent(out) :: flv type(vector4_t), intent(out) :: p integer, intent(out) :: i type(state_iterator_t) :: it type(flavor_t), dimension(int%n_tot) :: flv_array call it%init (int%state_matrix) flv_array = it%get_flavor () do i = int%n_in + int%n_vir + 1, int%n_tot if (.not. flv_array(i)%is_stable ()) then flv = flv_array(i) p = int%p(i) return end if end do end subroutine interaction_get_unstable_particle @ %def interaction_get_unstable_particle @ Return the complete set of \emph{outgoing} flavors, assuming that the flavor quantum number is not suppressed. <>= public :: interaction_get_flv_out <>= subroutine interaction_get_flv_out (int, flv) type(interaction_t), intent(in), target :: int type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv type(state_iterator_t) :: it type(flavor_t), dimension(:), allocatable :: flv_state integer :: n_in, n_vir, n_out, n_tot, n_state, i n_in = int%get_n_in () n_vir = int%get_n_vir () n_out = int%get_n_out () n_tot = int%get_n_tot () n_state = int%get_n_matrix_elements () allocate (flv (n_out, n_state)) allocate (flv_state (n_tot)) i = 1 call it%init (int%get_state_matrix_ptr ()) do while (it%is_valid ()) flv_state = it%get_flavor () flv(:,i) = flv_state(n_in + n_vir + 1 : ) i = i + 1 call it%advance () end do end subroutine interaction_get_flv_out @ %def interaction_get_flv_out @ Determine the flavor content of the interaction. We analyze the state matrix for this, and we select the outgoing particles of the hard process only for the required mask, which indicates the particles that can appear in any order in a matching event record. We have to assume that any radiated particles (beam remnants) appear at the beginning of the particles marked as outgoing. <>= public :: interaction_get_flv_content <>= subroutine interaction_get_flv_content (int, state_flv, n_out_hard) type(interaction_t), intent(in), target :: int type(state_flv_content_t), intent(out) :: state_flv integer, intent(in) :: n_out_hard logical, dimension(:), allocatable :: mask integer :: n_tot n_tot = int%get_n_tot () allocate (mask (n_tot), source = .false.) mask(n_tot-n_out_hard + 1 : ) = .true. call state_flv%fill (int%get_state_matrix_ptr (), mask) end subroutine interaction_get_flv_content @ %def interaction_get_flv_content @ \subsection{Modifying contents} Set the quantum numbers mask. <>= procedure :: set_mask => interaction_set_mask <>= subroutine interaction_set_mask (int, mask) class(interaction_t), intent(inout) :: int type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask if (size (int%mask) /= size (mask)) & call msg_fatal ("Attempting to set mask with unfitting size!") int%mask = mask int%update_state_matrix = .true. end subroutine interaction_set_mask @ %def interaction_set_mask @ Merge a particular mask entry, respecting a possible helicity lock for this entry. We apply an OR relation, which means that quantum numbers are summed over if either of the two masks requires it. <>= subroutine interaction_merge_mask_entry (int, i, mask) type(interaction_t), intent(inout) :: int integer, intent(in) :: i type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_mask_t) :: mask_tmp integer :: ii ii = idx (int, i) if (int%mask(ii) .neqv. mask) then int%mask(ii) = int%mask(ii) .or. mask if (int%hel_lock(ii) /= 0) then call mask_tmp%assign (mask, helicity=.true.) int%mask(int%hel_lock(ii)) = int%mask(int%hel_lock(ii)) .or. mask_tmp end if end if int%update_state_matrix = .true. end subroutine interaction_merge_mask_entry @ %def interaction_merge_mask_entry @ Fill the momenta array, do not care about the quantum numbers of particles. <>= procedure :: reset_momenta => interaction_reset_momenta procedure :: set_momenta => interaction_set_momenta procedure :: set_momentum => interaction_set_momentum <>= subroutine interaction_reset_momenta (int) class(interaction_t), intent(inout) :: int int%p = vector4_null int%p_is_known = .true. end subroutine interaction_reset_momenta subroutine interaction_set_momenta (int, p, outgoing) class(interaction_t), intent(inout) :: int type(vector4_t), dimension(:), intent(in) :: p logical, intent(in), optional :: outgoing integer :: i, index do i = 1, size (p) index = idx (int, i, outgoing) int%p(index) = p(i) int%p_is_known(index) = .true. end do end subroutine interaction_set_momenta subroutine interaction_set_momentum (int, p, i, outgoing) class(interaction_t), intent(inout) :: int type(vector4_t), intent(in) :: p integer, intent(in) :: i logical, intent(in), optional :: outgoing integer :: index index = idx (int, i, outgoing) int%p(index) = p int%p_is_known(index) = .true. end subroutine interaction_set_momentum @ %def interaction_reset_momenta @ %def interaction_set_momenta interaction_set_momentum @ This more sophisticated version of setting values is used for structure functions, in particular if nontrivial flavor, color, and helicity may be present: set values selectively for the given flavors. If there is more than one flavor, scan the interaction and check for a matching flavor at the specified particle location. If it matches, insert the value that corresponds to this flavor. <>= public :: interaction_set_flavored_values <>= subroutine interaction_set_flavored_values (int, value, flv_in, pos) type(interaction_t), intent(inout) :: int complex(default), dimension(:), intent(in) :: value type(flavor_t), dimension(:), intent(in) :: flv_in integer, intent(in) :: pos type(state_iterator_t) :: it type(flavor_t) :: flv integer :: i if (size (value) == 1) then call int%set_matrix_element (value(1)) else call it%init (int%state_matrix) do while (it%is_valid ()) flv = it%get_flavor (pos) SCAN_FLV: do i = 1, size (value) if (flv == flv_in(i)) then call it%set_matrix_element (value(i)) exit SCAN_FLV end if end do SCAN_FLV call it%advance () end do end if end subroutine interaction_set_flavored_values @ %def interaction_set_flavored_values @ \subsection{Handling Linked interactions} Store relations between corresponding particles within one interaction. The first particle is the parent, the second one the child. Links are established in both directions. These relations have no effect on the propagation of momenta etc., they are rather used for mother-daughter relations in event output. <>= procedure :: relate => interaction_relate <>= subroutine interaction_relate (int, i1, i2) class(interaction_t), intent(inout), target :: int integer, intent(in) :: i1, i2 if (i1 /= 0 .and. i2 /= 0) then call int%children(i1)%append (i2) call int%parents(i2)%append (i1) end if end subroutine interaction_relate @ %def interaction_relate @ Transfer internal parent-child relations defined within interaction [[int1]] to a new interaction [[int]] where the particle indices are mapped to. Some particles in [[int1]] may have no image in [[int]]. In that case, a child entry maps to zero, and we skip this relation. Also transfer resonance flags. <>= procedure :: transfer_relations => interaction_transfer_relations <>= subroutine interaction_transfer_relations (int1, int2, map) class(interaction_t), intent(in) :: int1 class(interaction_t), intent(inout), target :: int2 integer, dimension(:), intent(in) :: map integer :: i, j, k do i = 1, size (map) do j = 1, int1%parents(i)%get_length () k = int1%parents(i)%get_link (j) call int2%relate (map(k), map(i)) end do if (map(i) /= 0) then int2%resonant(map(i)) = int1%resonant(i) end if end do end subroutine interaction_transfer_relations @ %def interaction_transfer_relations @ Make up internal parent-child relations for the particle(s) that are connected to a new interaction [[int]]. If [[resonant]] is defined and true, the connections are marked as resonant in the result interaction <>= procedure :: relate_connections => interaction_relate_connections <>= subroutine interaction_relate_connections & (int, int_in, connection_index, & map, map_connections, resonant) class(interaction_t), intent(inout), target :: int class(interaction_t), intent(in) :: int_in integer, dimension(:), intent(in) :: connection_index integer, dimension(:), intent(in) :: map, map_connections logical, intent(in), optional :: resonant logical :: reson integer :: i, j, i2, k2 reson = .false.; if (present (resonant)) reson = resonant do i = 1, size (map_connections) k2 = connection_index(i) do j = 1, int_in%children(k2)%get_length () i2 = int_in%children(k2)%get_link (j) call int%relate (map_connections(i), map(i2)) end do int%resonant(map_connections(i)) = reson end do end subroutine interaction_relate_connections @ %def interaction_relate_connections. @ Return the number of source/target links of the internal connections of particle [[i]]. <>= public :: interaction_get_n_children public :: interaction_get_n_parents <>= function interaction_get_n_children (int, i) result (n) integer :: n type(interaction_t), intent(in) :: int integer, intent(in) :: i n = int%children(i)%get_length () end function interaction_get_n_children function interaction_get_n_parents (int, i) result (n) integer :: n type(interaction_t), intent(in) :: int integer, intent(in) :: i n = int%parents(i)%get_length () end function interaction_get_n_parents @ %def interaction_get_n_children interaction_get_n_parents @ Return the source/target links of the internal connections of particle [[i]] as an array. <>= public :: interaction_get_children public :: interaction_get_parents <>= function interaction_get_children (int, i) result (idx) integer, dimension(:), allocatable :: idx type(interaction_t), intent(in) :: int integer, intent(in) :: i integer :: k, l l = int%children(i)%get_length () allocate (idx (l)) do k = 1, l idx(k) = int%children(i)%get_link (k) end do end function interaction_get_children function interaction_get_parents (int, i) result (idx) integer, dimension(:), allocatable :: idx type(interaction_t), intent(in) :: int integer, intent(in) :: i integer :: k, l l = int%parents(i)%get_length () allocate (idx (l)) do k = 1, l idx(k) = int%parents(i)%get_link (k) end do end function interaction_get_parents @ %def interaction_get_children interaction_get_parents @ Add a source link from an interaction to a corresponding particle within another interaction. These links affect the propagation of particles: the two linked particles are considered as the same particle, outgoing and incoming. <>= procedure :: set_source_link => interaction_set_source_link <>= subroutine interaction_set_source_link (int, i, int1, i1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i class(interaction_t), intent(in), target :: int1 integer, intent(in) :: i1 if (i /= 0) call external_link_set (int%source(i), int1, i1) end subroutine interaction_set_source_link @ %def interaction_set_source_link @ Reassign links to a new interaction (which is an image of the current interaction). <>= public :: interaction_reassign_links <>= subroutine interaction_reassign_links (int, int_src, int_target) type(interaction_t), intent(inout) :: int type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target integer :: i if (allocated (int%source)) then do i = 1, size (int%source) call external_link_reassign (int%source(i), int_src, int_target) end do end if end subroutine interaction_reassign_links @ %def interaction_reassign_links @ Since links are one-directional, if we want to follow them backwards we have to scan all possibilities. This procedure returns the index of the particle within [[int]] which points to the particle [[i1]] within interaction [[int1]]. If unsuccessful, return zero. <>= public :: interaction_find_link <>= function interaction_find_link (int, int1, i1) result (i) integer :: i type(interaction_t), intent(in) :: int, int1 integer, intent(in) :: i1 type(interaction_t), pointer :: int_tmp do i = 1, int%n_tot int_tmp => external_link_get_ptr (int%source(i)) if (int_tmp%tag == int1%tag) then if (external_link_get_index (int%source(i)) == i1) return end if end do i = 0 end function interaction_find_link @ %def interaction_find_link @ The inverse: return interaction pointer and index for the ultimate source of [[i]] within [[int]]. <>= procedure :: find_source => interaction_find_source <>= subroutine interaction_find_source (int, i, int1, i1) class(interaction_t), intent(in) :: int integer, intent(in) :: i type(interaction_t), intent(out), pointer :: int1 integer, intent(out) :: i1 type(external_link_t) :: link link = interaction_get_ultimate_source (int, i) int1 => external_link_get_ptr (link) i1 = external_link_get_index (link) end subroutine interaction_find_source @ %def interaction_find_source @ Follow source links recursively to return the ultimate source of a particle. <>= function interaction_get_ultimate_source (int, i) result (link) type(external_link_t) :: link type(interaction_t), intent(in) :: int integer, intent(in) :: i type(interaction_t), pointer :: int_src integer :: i_src link = int%source(i) if (external_link_is_set (link)) then do int_src => external_link_get_ptr (link) i_src = external_link_get_index (link) if (external_link_is_set (int_src%source(i_src))) then link = int_src%source(i_src) else exit end if end do end if end function interaction_get_ultimate_source @ %def interaction_get_ultimate_source @ Update mask entries by merging them with corresponding masks in interactions linked to the current one. The mask determines quantum numbers which are summed over. Note that both the mask of the current interaction and the mask of the linked interaction are updated (side effect!). This ensures that both agree for the linked particle. <>= public :: interaction_exchange_mask <>= subroutine interaction_exchange_mask (int) type(interaction_t), intent(inout) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call interaction_merge_mask_entry & (int, i, int_link%mask(index_link)) call interaction_merge_mask_entry & (int_link, index_link, int%mask(i)) end if end do call int%freeze () end subroutine interaction_exchange_mask @ %def interaction_exchange_mask @ Copy momenta from interactions linked to the current one. <>= procedure :: receive_momenta => interaction_receive_momenta <>= subroutine interaction_receive_momenta (int) class(interaction_t), intent(inout) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call int%set_momentum (int_link%p(index_link), i) end if end do end subroutine interaction_receive_momenta @ %def interaction_receive_momenta @ The inverse operation: Copy momenta back to the interactions linked to the current one. <>= public :: interaction_send_momenta <>= subroutine interaction_send_momenta (int) type(interaction_t), intent(in) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call int_link%set_momentum (int%p(i), index_link) end if end do end subroutine interaction_send_momenta @ %def interaction_send_momenta @ For numerical comparisons: pacify all momenta in an interaction. <>= public :: interaction_pacify_momenta <>= subroutine interaction_pacify_momenta (int, acc) type(interaction_t), intent(inout) :: int real(default), intent(in) :: acc integer :: i do i = 1, int%n_tot call pacify (int%p(i), acc) end do end subroutine interaction_pacify_momenta @ %def interaction_pacify_momenta @ For each subtraction entry starting from [[SUB = 0]], we duplicate the original state matrix entries as is. <>= procedure :: declare_subtraction => interaction_declare_subtraction <>= subroutine interaction_declare_subtraction (int, n_sub) class(interaction_t), intent(inout), target :: int integer, intent(in) :: n_sub integer :: i_sub type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_matrix_t) :: state_matrix call state_matrix%init (store_values = .true.) allocate (qn (int%get_state_depth ())) do i_sub = 0, n_sub call it%init (int%state_matrix) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%set_subtraction_index (i_sub) call state_matrix%add_state (qn, value = it%get_matrix_element ()) call it%advance () end do end do call state_matrix%freeze () call state_matrix%set_n_sub () call int%state_matrix%final () int%state_matrix = state_matrix end subroutine interaction_declare_subtraction @ %def interaction_declare_subtraction @ \subsection{Recovering connections} When creating an evaluator for two interactions, we have to know by which particles they are connected. The connection indices can be determined if we have two linked interactions. We assume that [[int1]] is the source and [[int2]] the target, so the connections of interest are stored within [[int2]]. A connection is found if either the source is [[int1]], or the (ultimate) source of a particle within [[int2]] coincides with the (ultimate) source of a aparticle within [[int1]]. The result is an array of index pairs. To make things simple, we scan the interaction twice, once for counting hits, then allocate the array, then scan again and store the connections. The connections are scanned for [[int2]], which has sources in [[int1]]. It may happen that the order of connections is interchanged (crossed). We require the indices in [[int1]] to be sorted, so we reorder both index arrays correspondingly before returning them. (After this, the indices in [[int2]] may be out of order.) <>= public :: find_connections <>= subroutine find_connections (int1, int2, n, connection_index) class(interaction_t), intent(in) :: int1, int2 integer, intent(out) :: n integer, dimension(:,:), intent(out), allocatable :: connection_index integer, dimension(:,:), allocatable :: conn_index_tmp integer, dimension(:), allocatable :: ordering integer :: i, j, k type(external_link_t) :: link1, link2 type(interaction_t), pointer :: int_link1, int_link2 n = 0 do i = 1, size (int2%source) link2 = interaction_get_ultimate_source (int2, i) if (external_link_is_set (link2)) then int_link2 => external_link_get_ptr (link2) if (int_link2%tag == int1%tag) then n = n + 1 else k = external_link_get_index (link2) do j = 1, size (int1%source) link1 = interaction_get_ultimate_source (int1, j) if (external_link_is_set (link1)) then int_link1 => external_link_get_ptr (link1) if (int_link1%tag == int_link2%tag) then if (external_link_get_index (link1) == k) & n = n + 1 end if end if end do end if end if end do allocate (conn_index_tmp (n, 2)) n = 0 do i = 1, size (int2%source) link2 = interaction_get_ultimate_source (int2, i) if (external_link_is_set (link2)) then int_link2 => external_link_get_ptr (link2) if (int_link2%tag == int1%tag) then n = n + 1 conn_index_tmp(n,1) = external_link_get_index (int2%source(i)) conn_index_tmp(n,2) = i else k = external_link_get_index (link2) do j = 1, size (int1%source) link1 = interaction_get_ultimate_source (int1, j) if (external_link_is_set (link1)) then int_link1 => external_link_get_ptr (link1) if (int_link1%tag == int_link2%tag) then if (external_link_get_index (link1) == k) then n = n + 1 conn_index_tmp(n,1) = j conn_index_tmp(n,2) = i end if end if end if end do end if end if end do allocate (connection_index (n, 2)) if (n > 1) then allocate (ordering (n)) ordering = order (conn_index_tmp(:,1)) connection_index = conn_index_tmp(ordering,:) else connection_index = conn_index_tmp end if end subroutine find_connections @ %def find_connections @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[interactions_ut.f90]]>>= <> module interactions_ut use unit_tests use interactions_uti <> <> contains <> end module interactions_ut @ %def interactions_ut @ <<[[interactions_uti.f90]]>>= <> module interactions_uti <> use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices use interactions <> <> contains <> end module interactions_uti @ %def interactions_ut @ API: driver for the unit tests below. <>= public :: interaction_test <>= subroutine interaction_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine interaction_test @ %def interaction_test @ Generate an interaction of a polarized virtual photon and a colored quark which may be either up or down. Remove the quark polarization. Generate another interaction for the quark radiating a photon and link this to the first interation. The radiation ignores polarization; transfer this information to the first interaction to simplify it. Then, transfer the momentum to the radiating quark and perform a splitting. <>= call test (interaction_1, "interaction_1", & "check interaction setup", & u, results) <>= public :: interaction_1 <>= subroutine interaction_1 (u) integer, intent(in) :: u type(interaction_t), target :: int, rad type(vector4_t), dimension(3) :: p type(quantum_numbers_mask_t), dimension(3) :: mask p(2) = vector4_moving (500._default, 500._default, 1) p(3) = vector4_moving (500._default,-500._default, 1) p(1) = p(2) + p(3) write (u, "(A)") "* Test output: interaction" write (u, "(A)") "* Purpose: check routines for interactions" write (u, "(A)") call int%basic_init (1, 0, 2, set_relations=.true., & store_values = .true. ) call int_set (int, 1, -1, 1, 1, & cmplx (0.3_default, 0.1_default, kind=default)) call int_set (int, 1, -1,-1, 1, & cmplx (0.5_default,-0.7_default, kind=default)) call int_set (int, 1, 1, 1, 1, & cmplx (0.1_default, 0._default, kind=default)) call int_set (int, -1, 1, -1, 2, & cmplx (0.4_default, -0.1_default, kind=default)) call int_set (int, 1, 1, 1, 2, & cmplx (0.2_default, 0._default, kind=default)) call int%freeze () call int%set_momenta (p) mask = quantum_numbers_mask (.false.,.false., [.true.,.true.,.true.]) call rad%basic_init (1, 0, 2, & mask=mask, set_relations=.true., store_values = .true.) call rad_set (1) call rad_set (2) call rad%set_source_link (1, int, 2) call interaction_exchange_mask (rad) call rad%receive_momenta () p(1) = rad%get_momentum (1) p(2) = 0.4_default * p(1) p(3) = p(1) - p(2) call rad%set_momenta (p(2:3), outgoing=.true.) call int%freeze () call rad%freeze () call rad%set_matrix_element & (cmplx (0._default, 0._default, kind=default)) call int%basic_write (u) write (u, "(A)") call rad%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call rad%final () write (u, "(A)") write (u, "(A)") "* Test interaction_1: successful." contains subroutine int_set (int, h1, h2, hq, q, val) type(interaction_t), target, intent(inout) :: int integer, intent(in) :: h1, h2, hq, q type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(helicity_t), dimension(3) :: hel type(quantum_numbers_t), dimension(3) :: qn complex(default), intent(in) :: val call flv%init ([21, q, -q]) call col(2)%init_col_acl (5, 0) call col(3)%init_col_acl (0, 5) call hel%init ([h1, hq, -hq], [h2, hq, -hq]) call qn%init (flv, col, hel) call int%add_state (qn) call int%set_matrix_element (val) end subroutine int_set subroutine rad_set (q) integer, intent(in) :: q type(flavor_t), dimension(3) :: flv type(quantum_numbers_t), dimension(3) :: qn call flv%init ([ q, q, 21 ]) call qn%init (flv) call rad%add_state (qn) end subroutine rad_set end subroutine interaction_1 @ %def interaction_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Matrix element evaluation} The [[evaluator_t]] type is an extension of the [[interaction_t]] type. It represents either a density matrix as the square of a transition matrix element, or the product of two density matrices. Usually, some quantum numbers are summed over in the result. The [[interaction_t]] subobject represents a multi-particle interaction with incoming, virtual, and outgoing particles and the associated (not necessarily diagonal) density matrix of quantum state. When the evaluator is initialized, this interaction is constructed from the input interaction(s). In addition, the initialization process sets up a multiplication table. For each matrix element of the result, it states which matrix elements are to be taken from the input interaction(s), multiplied (optionally, with an additional weight factor) and summed over. Eventually, to a processes we associate a chain of evaluators which are to be evaluated sequentially. The physical event and its matrix element value(s) can be extracted from the last evaluator in such a chain. Evaluators are constructed only once (as long as this is possible) during an initialization step. Then, for each event, momenta are computed and transferred among evaluators using the links within the interaction subobject. The multiplication tables enable fast evaluation of the result without looking at quantum numbers anymore. <<[[evaluators.f90]]>>= <> module evaluators <> <> use io_units use format_defs, only: FMT_19 use physics_defs, only: n_beam_structure_int use diagnostics use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices use interactions <> <> <> <> <> contains <> end module evaluators @ %def evaluators @ \subsection{Array of pairings} The evaluator contains an array of [[pairing_array]] objects. This makes up the multiplication table. Each pairing array contains two list of matrix element indices and a list of numerical factors. The matrix element indices correspond to the input interactions. The corresponding matrix elements are to be multiplied and optionally multiplied by a factor. The results are summed over to yield one specific matrix element of the result evaluator. <>= type :: pairing_array_t integer, dimension(:), allocatable :: i1, i2 complex(default), dimension(:), allocatable :: factor end type pairing_array_t @ %def pairing_array_t <>= elemental subroutine pairing_array_init (pa, n, has_i2, has_factor) type(pairing_array_t), intent(out) :: pa integer, intent(in) :: n logical, intent(in) :: has_i2, has_factor allocate (pa%i1 (n)) if (has_i2) allocate (pa%i2 (n)) if (has_factor) allocate (pa%factor (n)) end subroutine pairing_array_init @ %def pairing_array_init @ <>= public :: pairing_array_write <>= subroutine pairing_array_write (pa, unit) type(pairing_array_t), intent(in) :: pa integer, intent(in), optional :: unit integer :: i, u u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance = "no") "[" if (allocated (pa%i1)) then write (u, "(I0,A)", advance = "no") pa%i1, "," else write (u, "(A)", advance = "no") "x," end if if (allocated (pa%i2)) then write (u, "(I0,A)", advance = "no") pa%i1, "," else write (u, "(A)", advance = "no") "x," end if write (u, "(A)", advance = "no") "]" if (allocated (pa%factor)) then write (u, "(A,F5.4,A,F5.4,A)") ";(", & real(pa%factor), ",", aimag(pa%factor), ")]" else write (u, "(A)") "" end if end subroutine pairing_array_write @ %def pairing_array_write @ \subsection{The evaluator type} Possible variants of evaluators: <>= integer, parameter :: & EVAL_UNDEFINED = 0, & EVAL_PRODUCT = 1, & EVAL_SQUARED_FLOWS = 2, & EVAL_SQUARE_WITH_COLOR_FACTORS = 3, & EVAL_COLOR_CONTRACTION = 4, & EVAL_IDENTITY = 5, & EVAL_QN_SUM = 6 @ %def EVAL_PRODUCT EVAL_SQUARED_FLOWS EVAL_SQUARE_WITH_COLOR_FACTORS @ %def EVAL_COLOR_CONTRACTION EVAL_QN_SUM @ The evaluator type contains the result interaction and an array of pairing lists, one for each matrix element in the result interaction. <>= public :: evaluator_t <>= type, extends (interaction_t) :: evaluator_t private integer :: type = EVAL_UNDEFINED class(interaction_t), pointer :: int_in1 => null () class(interaction_t), pointer :: int_in2 => null () type(pairing_array_t), dimension(:), allocatable :: pairing_array contains <> end type evaluator_t @ %def evaluator_t @ Output. <>= procedure :: write => evaluator_write <>= subroutine evaluator_write (eval, unit, & verbose, show_momentum_sum, show_mass, show_state, show_table, & col_verbose, testflag) class(evaluator_t), intent(in) :: eval integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: show_state, show_table, col_verbose logical, intent(in), optional :: testflag logical :: conjugate, square, show_tab integer :: u u = given_output_unit (unit); if (u < 0) return show_tab = .true.; if (present (show_table)) show_tab = .false. call eval%basic_write & (unit, verbose, show_momentum_sum, show_mass, & show_state, col_verbose, testflag) if (show_tab) then write (u, "(1x,A)") "Matrix-element multiplication" write (u, "(2x,A)", advance="no") "Input interaction 1:" if (associated (eval%int_in1)) then write (u, "(1x,I0)") eval%int_in1%get_tag () else write (u, "(A)") " [undefined]" end if write (u, "(2x,A)", advance="no") "Input interaction 2:" if (associated (eval%int_in2)) then write (u, "(1x,I0)") eval%int_in2%get_tag () else write (u, "(A)") " [undefined]" end if select case (eval%type) case (EVAL_SQUARED_FLOWS, EVAL_SQUARE_WITH_COLOR_FACTORS) conjugate = .true. square = .true. case (EVAL_IDENTITY) write (u, "(1X,A)") "Identity evaluator, pairing array unused" return case default conjugate = .false. square = .false. end select call eval%write_pairing_array (conjugate, square, u) end if end subroutine evaluator_write @ %def evaluator_write @ <>= procedure :: write_pairing_array => evaluator_write_pairing_array <>= subroutine evaluator_write_pairing_array (eval, conjugate, square, unit) class(evaluator_t), intent(in) :: eval logical, intent(in) :: conjugate, square integer, intent(in), optional :: unit integer :: u, i, j u = given_output_unit (unit); if (u < 0) return if (allocated (eval%pairing_array)) then do i = 1, size (eval%pairing_array) write (u, "(2x,A,I0,A)") "ME(", i, ") = " do j = 1, size (eval%pairing_array(i)%i1) write (u, "(4x,A)", advance="no") "+" if (allocated (eval%pairing_array(i)%i2)) then write (u, "(1x,A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" if (conjugate) then write (u, "(A)", advance="no") "* x" else write (u, "(A)", advance="no") " x" end if write (u, "(1x,A,I0,A)", advance="no") & "ME2(", eval%pairing_array(i)%i2(j), ")" else if (square) then write (u, "(1x,A)", advance="no") "|" write (u, "(A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" write (u, "(A)", advance="no") "|^2" else write (u, "(1x,A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" end if if (allocated (eval%pairing_array(i)%factor)) then write (u, "(1x,A)", advance="no") "x" write (u, "(1x,'('," // FMT_19 // ",','," // FMT_19 // & ",')')") eval%pairing_array(i)%factor(j) else write (u, *) end if end do end do end if end subroutine evaluator_write_pairing_array @ %def evaluator_write_pairing_array @ Assignment: Deep copy of the interaction component. <>= public :: assignment(=) <>= interface assignment(=) module procedure evaluator_assign end interface <>= subroutine evaluator_assign (eval_out, eval_in) type(evaluator_t), intent(out) :: eval_out type(evaluator_t), intent(in) :: eval_in eval_out%type = eval_in%type eval_out%int_in1 => eval_in%int_in1 eval_out%int_in2 => eval_in%int_in2 eval_out%interaction_t = eval_in%interaction_t if (allocated (eval_in%pairing_array)) then allocate (eval_out%pairing_array (size (eval_in%pairing_array))) eval_out%pairing_array = eval_in%pairing_array end if end subroutine evaluator_assign @ %def evaluator_assign @ \subsection{Auxiliary structures for evaluator creation} Creating an evaluator that properly handles all quantum numbers requires some bookkeeping. In this section, we define several auxiliary types and methods that organize and simplify this task. More structures are defined within the specific initializers (as local types and internal subroutines). These types are currently implemented in a partial object-oriented way: We define some basic methods for initialization etc.\ here, but the evaluator routines below do access their internals as well. This simplifies some things such as index addressing using array slices, at the expense of losing some clarity. \subsubsection{Index mapping} Index mapping are abundant when constructing an evaluator. To have arrays of index mappings, we define this: <>= type :: index_map_t integer, dimension(:), allocatable :: entry end type index_map_t @ %def index_map_t <>= elemental subroutine index_map_init (map, n) type(index_map_t), intent(out) :: map integer, intent(in) :: n allocate (map%entry (n)) map%entry = 0 end subroutine index_map_init @ %def index_map_init <>= function index_map_exists (map) result (flag) logical :: flag type(index_map_t), intent(in) :: map flag = allocated (map%entry) end function index_map_exists @ %def index_map_exists <>= interface size module procedure index_map_size end interface @ %def size <>= function index_map_size (map) result (s) integer :: s type(index_map_t), intent(in) :: map if (allocated (map%entry)) then s = size (map%entry) else s = 0 end if end function index_map_size @ %def index_map_size <>= interface assignment(=) module procedure index_map_assign_int module procedure index_map_assign_array end interface @ %def = <>= elemental subroutine index_map_assign_int (map, ival) type(index_map_t), intent(inout) :: map integer, intent(in) :: ival map%entry = ival end subroutine index_map_assign_int subroutine index_map_assign_array (map, array) type(index_map_t), intent(inout) :: map integer, dimension(:), intent(in) :: array map%entry = array end subroutine index_map_assign_array @ %def index_map_assign_int index_map_assign_array <>= elemental subroutine index_map_set_entry (map, i, ival) type(index_map_t), intent(inout) :: map integer, intent(in) :: i integer, intent(in) :: ival map%entry(i) = ival end subroutine index_map_set_entry @ %def index_map_set_entry <>= elemental function index_map_get_entry (map, i) result (ival) integer :: ival type(index_map_t), intent(in) :: map integer, intent(in) :: i ival = map%entry(i) end function index_map_get_entry @ %def index_map_get_entry @ \subsubsection{Index mapping (two-dimensional)} This is a variant with a square matrix instead of an array. <>= type :: index_map2_t integer :: s = 0 integer, dimension(:,:), allocatable :: entry end type index_map2_t @ %def index_map2_t <>= elemental subroutine index_map2_init (map, n) type(index_map2_t), intent(out) :: map integer, intent(in) :: n map%s = n allocate (map%entry (n, n)) end subroutine index_map2_init @ %def index_map2_init <>= function index_map2_exists (map) result (flag) logical :: flag type(index_map2_t), intent(in) :: map flag = allocated (map%entry) end function index_map2_exists @ %def index_map2_exists <>= interface size module procedure index_map2_size end interface @ %def size <>= function index_map2_size (map) result (s) integer :: s type(index_map2_t), intent(in) :: map s = map%s end function index_map2_size @ %def index_map2_size <>= interface assignment(=) module procedure index_map2_assign_int end interface @ %def = <>= elemental subroutine index_map2_assign_int (map, ival) type(index_map2_t), intent(inout) :: map integer, intent(in) :: ival map%entry = ival end subroutine index_map2_assign_int @ %def index_map2_assign_int <>= elemental subroutine index_map2_set_entry (map, i, j, ival) type(index_map2_t), intent(inout) :: map integer, intent(in) :: i, j integer, intent(in) :: ival map%entry(i,j) = ival end subroutine index_map2_set_entry @ %def index_map2_set_entry <>= elemental function index_map2_get_entry (map, i, j) result (ival) integer :: ival type(index_map2_t), intent(in) :: map integer, intent(in) :: i, j ival = map%entry(i,j) end function index_map2_get_entry @ %def index_map2_get_entry @ \subsubsection{Auxiliary structures: particle mask} This is a simple container of a logical array. <>= type :: prt_mask_t logical, dimension(:), allocatable :: entry end type prt_mask_t @ %def prt_mask_t <>= subroutine prt_mask_init (mask, n) type(prt_mask_t), intent(out) :: mask integer, intent(in) :: n allocate (mask%entry (n)) end subroutine prt_mask_init @ %def prt_mask_init <>= interface size module procedure prt_mask_size end interface @ %def size <>= function prt_mask_size (mask) result (s) integer :: s type(prt_mask_t), intent(in) :: mask s = size (mask%entry) end function prt_mask_size @ %def prt_mask_size @ \subsubsection{Quantum number containers} Trivial transparent containers: <>= type :: qn_list_t type(quantum_numbers_t), dimension(:,:), allocatable :: qn end type qn_list_t type :: qn_mask_array_t type(quantum_numbers_mask_t), dimension(:), allocatable :: mask end type qn_mask_array_t @ %def qn_list_t qn_mask_array_t @ \subsubsection{Auxiliary structures: connection entries} This type is used as intermediate storage when computing the product of two evaluators or the square of an evaluator. The quantum-number array [[qn]] corresponds to the particles common to both interactions, but irrelevant quantum numbers (color) masked out. The index arrays [[index_in]] determine the entries in the input interactions that contribute to this connection. [[n_index]] is the size of these arrays, and [[count]] is used while filling the entries. Finally, the quantum-number arrays [[qn_in_list]] are the actual entries in the input interaction that contribute. In the product case, they exclude the connected quantum numbers. Each evaluator has its own [[connection_table]] which contains an array of [[connection_entry]] objects, but also has stuff that specifically applies to the evaluator type. Hence, we do not generalize the [[connection_table_t]] type. The filling procedure [[connection_entry_add_state]] is specific to the various evaluator types. <>= type :: connection_entry_t type(quantum_numbers_t), dimension(:), allocatable :: qn_conn integer, dimension(:), allocatable :: n_index integer, dimension(:), allocatable :: count type(index_map_t), dimension(:), allocatable :: index_in type(qn_list_t), dimension(:), allocatable :: qn_in_list end type connection_entry_t @ %def connection_entry_t <>= subroutine connection_entry_init & (entry, n_count, n_map, qn_conn, count, n_rest) type(connection_entry_t), intent(out) :: entry integer, intent(in) :: n_count, n_map type(quantum_numbers_t), dimension(:), intent(in) :: qn_conn integer, dimension(n_count), intent(in) :: count integer, dimension(n_count), intent(in) :: n_rest integer :: i allocate (entry%qn_conn (size (qn_conn))) allocate (entry%n_index (n_count)) allocate (entry%count (n_count)) allocate (entry%index_in (n_map)) allocate (entry%qn_in_list (n_count)) entry%qn_conn = qn_conn entry%n_index = count entry%count = 0 if (size (entry%index_in) == size (count)) then call index_map_init (entry%index_in, count) else call index_map_init (entry%index_in, count(1)) end if do i = 1, n_count allocate (entry%qn_in_list(i)%qn (n_rest(i), count(i))) end do end subroutine connection_entry_init @ %def connection_entry_init <>= subroutine connection_entry_write (entry, unit) type(connection_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) call quantum_numbers_write (entry%qn_conn, unit) write (u, *) do i = 1, size (entry%n_index) write (u, *) "Input interaction", i do j = 1, entry%n_index(i) if (size (entry%n_index) == size (entry%index_in)) then write (u, "(2x,I0,4x,I0,2x)", advance = "no") & j, index_map_get_entry (entry%index_in(i), j) else write (u, "(2x,I0,4x,I0,2x,I0,2x)", advance = "no") & j, index_map_get_entry (entry%index_in(1), j), & index_map_get_entry (entry%index_in(2), j) end if call quantum_numbers_write (entry%qn_in_list(i)%qn(:,j), unit) write (u, *) end do end do end subroutine connection_entry_write @ %def connection_entry_write @ \subsubsection{Color handling} For managing color-factor computation, we introduce this local type. The [[index]] is the index in the color table that corresponds to a given matrix element index in the input interaction. The [[col]] array stores the color assignments in rows. The [[factor]] array associates a complex number with each pair of arrays in the color table. The [[factor_is_known]] array reveals whether a given factor is known already or still has to be computed. <>= type :: color_table_t integer, dimension(:), allocatable :: index type(color_t), dimension(:,:), allocatable :: col logical, dimension(:,:), allocatable :: factor_is_known complex(default), dimension(:,:), allocatable :: factor end type color_table_t @ %def color_table_t @ This is the initializer. We extract the color states from the given state matrices, establish index mappings between the two states (implemented by the array [[me_index]]), make an array of color states, and initialize the color-factor table. The latter is two-dimensional (includes interference) and not yet filled. <>= subroutine color_table_init (color_table, state, n_tot) type(color_table_t), intent(out) :: color_table type(state_matrix_t), intent(in) :: state integer, intent(in) :: n_tot type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_matrix_t) :: state_col integer :: index, n_col_state allocate (color_table%index (state%get_n_matrix_elements ())) color_table%index = 0 allocate (qn (n_tot)) call state_col%init () call it%init (state) do while (it%is_valid ()) index = it%get_me_index () call qn%init (col = it%get_color ()) call state_col%add_state (qn, me_index = color_table%index(index)) call it%advance () end do n_col_state = state_col%get_n_matrix_elements () allocate (color_table%col (n_tot, n_col_state)) call it%init (state_col) do while (it%is_valid ()) index = it%get_me_index () color_table%col(:,index) = it%get_color () call it%advance () end do call state_col%final () allocate (color_table%factor_is_known (n_col_state, n_col_state)) allocate (color_table%factor (n_col_state, n_col_state)) color_table%factor_is_known = .false. end subroutine color_table_init @ %def color_table_init @ Output (debugging use): <>= subroutine color_table_write (color_table, unit) type(color_table_t), intent(in) :: color_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Color table:" if (allocated (color_table%index)) then write (u, *) " Index mapping state => color table:" do i = 1, size (color_table%index) write (u, "(3x,I0,2x,I0,2x)") i, color_table%index(i) end do write (u, *) " Color table:" do i = 1, size (color_table%col, 2) write (u, "(3x,I0,2x)", advance = "no") i call color_write (color_table%col(:,i), unit) write (u, *) end do write (u, *) " Defined color factors:" do i = 1, size (color_table%factor, 1) do j = 1, size (color_table%factor, 2) if (color_table%factor_is_known(i,j)) then write (u, *) i, j, color_table%factor(i,j) end if end do end do end if end subroutine color_table_write @ %def color_table_write @ This subroutine sets color factors, based on information from the hard matrix element: the list of pairs of color-flow indices (in the basis of the matrix element code), the list of corresponding factors, and the list of mappings from the matrix element index in the input interaction to the color-flow index in the hard matrix element object. We first determine the mapping of color-flow indices from the hard matrix element code to the current color table. The mapping could be nontrivial because the latter is derived from iterating over a state matrix, which may return states in non-canonical order. The translation table can be determined because we have, for the complete state matrix, both the mapping to the hard interaction (the input [[col_index_hi]]) and the mapping to the current color table (the component [[color_table%index]]). Once this mapping is known, we scan the list of index pairs [[color_flow_index]] and translate them to valid color-table index pairs. For this pair, the color factor is set using the corresponding entry in the list [[col_factor]]. <>= subroutine color_table_set_color_factors (color_table, & col_flow_index, col_factor, col_index_hi) type(color_table_t), intent(inout) :: color_table integer, dimension(:,:), intent(in) :: col_flow_index complex(default), dimension(:), intent(in) :: col_factor integer, dimension(:), intent(in) :: col_index_hi integer, dimension(:), allocatable :: hi_to_ct integer :: n_cflow integer :: hi_index, me_index, ct_index, cf_index integer, dimension(2) :: hi_index_pair, ct_index_pair n_cflow = size (col_index_hi) if (size (color_table%index) /= n_cflow) & call msg_bug ("Mismatch between hard matrix element and color table") allocate (hi_to_ct (n_cflow)) do me_index = 1, size (color_table%index) ct_index = color_table%index(me_index) hi_index = col_index_hi(me_index) hi_to_ct(hi_index) = ct_index end do do cf_index = 1, size (col_flow_index, 2) hi_index_pair = col_flow_index(:,cf_index) ct_index_pair = hi_to_ct(hi_index_pair) color_table%factor(ct_index_pair(1), ct_index_pair(2)) = & col_factor(cf_index) color_table%factor_is_known(ct_index_pair(1), ct_index_pair(2)) = .true. end do end subroutine color_table_set_color_factors @ %def color_table_set_color_factors @ This function returns a color factor, given two indices which point to the matrix elements of the initial state matrix. Internally, we can map them to the corresponding indices in the color table. As a side effect, we store the color factor in the color table for later lookup. (I.e., this function is impure.) <>= function color_table_get_color_factor (color_table, index1, index2, nc) & result (factor) real(default) :: factor type(color_table_t), intent(inout) :: color_table integer, intent(in) :: index1, index2 integer, intent(in), optional :: nc integer :: i1, i2 i1 = color_table%index(index1) i2 = color_table%index(index2) if (color_table%factor_is_known(i1,i2)) then factor = real(color_table%factor(i1,i2), kind=default) else factor = compute_color_factor & (color_table%col(:,i1), color_table%col(:,i2), nc) color_table%factor(i1,i2) = factor color_table%factor_is_known(i1,i2) = .true. end if end function color_table_get_color_factor @ %def color_table_get_color_factor @ \subsection{Creating an evaluator: Matrix multiplication} The evaluator for matrix multiplication is the most complicated variant. The initializer takes two input interactions and constructs the result evaluator, which consists of the interaction and the multiplication table for the product (or convolution) of the two. Normally, the input interactions are connected by one or more common particles (e.g., decay, structure function convolution). In the result interaction, quantum numbers of the connections can be summed over. This is determined by the [[qn_mask_conn]] argument. The [[qn_mask_rest]] argument is its analog for the other particles within the result interaction. (E.g., for the trace of the state matrix, all quantum numbers are summed over.) Finally, the [[connections_are_resonant]] argument tells whether the connecting particles should be marked as resonant in the final event record. This is useful for decays. The algorithm consists of the following steps: \begin{enumerate} \item [[find_connections]]: Find the particles which are connected, i.e., common to both input interactions. Either they are directly linked, or both are linked to a common source. \item [[compute_index_bounds_and_mappings]]: Compute the mappings of particle indices from the input interactions to the result interaction. There is a separate mapping for the connected particles. \item [[accumulate_connected_states]]: Create an auxiliary state matrix which lists the possible quantum numbers for the connected particles. When building this matrix, count the number of times each assignment is contained in any of the input states and, for each of the input states, record the index of the matrix element within the new state matrix. For the connected particles, reassign color indices such that no color state is present twice in different color-index assignment. Note that helicity assignments of the connected state can be (and will be) off-diagonal, so no spin correlations are lost in decays. Do this for both input interactions. \item [[allocate_connection_entries]]: Allocate a table of connections. Each table row corresponds to one state in the auxiliary matrix, and to multiple states of the input interactions. It collects all states of the unconnected particles in the two input interactions that are associated with the particular state (quantum-number assignment) of the connected particles. \item [[fill_connection_table]]: Fill the table of connections by scanning both input interactions. When copying states, reassign color indices for the unconnected particles such that they match between all involved particle sets (interaction 1, interaction 2, and connected particles). \item [[make_product_interaction]]: Scan the table of connections we have just built. For each entry, construct all possible pairs of states of the unconnected particles and combine them with the specific connected-particle state. This is a possible quantum-number assignment of the result interaction. Now mask all quantum numbers that should be summed over, and append this to the result state matrix. Record the matrix element index of the result. We now have the result interaction. \item [[make_pairing_array]]: First allocate the pairing array with the number of entries of the result interaction. Then scan the table of connections again. For each entry, record the indices of the matrix elements which have to be multiplied and summed over in order to compute this particular matrix element. This makes up the multiplication table. \item [[record_links]]: Transfer all source pointers from the input interactions to the result interaction. Do the same for the internal parent-child relations and resonance assignments. For the connected particles, make up appropriate additional parent-child relations. This allows for fetching momenta from other interactions when a new event is filled, and to reconstruct the event history when the event is analyzed. \end{enumerate} After all this is done, for each event, we just have to evaluate the pairing arrays (multiplication tables) in order to compute the result matrix elements in their proper positions. The quantum-number assignments remain fixed from now on. <>= procedure :: init_product => evaluator_init_product <>= subroutine evaluator_init_product & (eval, int_in1, int_in2, qn_mask_conn, qn_filter_conn, qn_mask_rest, & connections_are_resonant, ignore_sub) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in1, int_in2 type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest logical, intent(in), optional :: connections_are_resonant logical, intent(in), optional :: ignore_sub type(qn_mask_array_t), dimension(2) :: qn_mask_in type(state_matrix_t), pointer :: state_in1, state_in2 type :: connection_table_t integer :: n_conn = 0 integer, dimension(2) :: n_rest = 0 integer :: n_tot = 0 integer :: n_me_conn = 0 type(state_matrix_t) :: state type(index_map_t), dimension(:), allocatable :: index_conn type(connection_entry_t), dimension(:), allocatable :: entry type(index_map_t) :: index_result end type connection_table_t type(connection_table_t) :: connection_table integer :: n_in, n_vir, n_out, n_tot integer, dimension(2) :: n_rest integer :: n_conn integer, dimension(:,:), allocatable :: connection_index type(index_map_t), dimension(2) :: prt_map_in type(index_map_t) :: prt_map_conn type(prt_mask_t), dimension(2) :: prt_is_connected type(quantum_numbers_mask_t), dimension(:), allocatable :: & qn_mask_conn_initial, int_in1_mask, int_in2_mask integer :: i eval%type = EVAL_PRODUCT eval%int_in1 => int_in1 eval%int_in2 => int_in2 state_in1 => int_in1%get_state_matrix_ptr () state_in2 => int_in2%get_state_matrix_ptr () call find_connections (int_in1, int_in2, n_conn, connection_index) if (n_conn == 0) then call msg_message ("First interaction:") call int_in1%basic_write (col_verbose=.true.) call msg_message ("Second interaction:") call int_in2%basic_write (col_verbose=.true.) call msg_fatal ("Evaluator product: no connections found between factors") end if call compute_index_bounds_and_mappings & (int_in1, int_in2, n_conn, & n_in, n_vir, n_out, n_tot, & n_rest, prt_map_in, prt_map_conn) call prt_mask_init (prt_is_connected(1), int_in1%get_n_tot ()) call prt_mask_init (prt_is_connected(2), int_in2%get_n_tot ()) do i = 1, 2 prt_is_connected(i)%entry = .true. prt_is_connected(i)%entry(connection_index(:,i)) = .false. end do allocate (qn_mask_conn_initial (n_conn), & int_in1_mask (n_conn), int_in2_mask (n_conn)) int_in1_mask = int_in1%get_mask (connection_index(:,1)) int_in2_mask = int_in2%get_mask (connection_index(:,2)) do i = 1, n_conn qn_mask_conn_initial(i) = int_in1_mask(i) .or. int_in2_mask(i) end do allocate (qn_mask_in(1)%mask (int_in1%get_n_tot ())) allocate (qn_mask_in(2)%mask (int_in2%get_n_tot ())) qn_mask_in(1)%mask = int_in1%get_mask () qn_mask_in(2)%mask = int_in2%get_mask () call connection_table_init (connection_table, & state_in1, state_in2, & qn_mask_conn_initial, & n_conn, connection_index, n_rest, & qn_filter_conn, ignore_sub) call connection_table_fill (connection_table, & state_in1, state_in2, & connection_index, prt_is_connected) call make_product_interaction (eval%interaction_t, & n_in, n_vir, n_out, & connection_table, & prt_map_in, prt_is_connected, & qn_mask_in, qn_mask_conn_initial, & qn_mask_conn, qn_filter_conn, qn_mask_rest) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table) call record_links (eval%interaction_t, & int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, & prt_is_connected, connections_are_resonant) call connection_table_final (connection_table) if (eval%get_n_matrix_elements () == 0) then print *, "Evaluator product" print *, "First interaction" call int_in1%basic_write (col_verbose=.true.) print * print *, "Second interaction" call int_in2%basic_write (col_verbose=.true.) print * call msg_fatal ("Product of density matrices is empty", & [var_str (" --------------------------------------------"), & var_str ("This happens when two density matrices are convoluted "), & var_str ("but the processes they belong to (e.g., production "), & var_str ("and decay) do not match. This could happen if the "), & var_str ("beam specification does not match the hard "), & var_str ("process. Or it may indicate a WHIZARD bug.")]) end if contains subroutine compute_index_bounds_and_mappings & (int1, int2, n_conn, & n_in, n_vir, n_out, n_tot, & n_rest, prt_map_in, prt_map_conn) class(interaction_t), intent(in) :: int1, int2 integer, intent(in) :: n_conn integer, intent(out) :: n_in, n_vir, n_out, n_tot integer, dimension(2), intent(out) :: n_rest type(index_map_t), dimension(2), intent(out) :: prt_map_in type(index_map_t), intent(out) :: prt_map_conn integer, dimension(:), allocatable :: index integer :: n_in1, n_vir1, n_out1 integer :: n_in2, n_vir2, n_out2 integer :: k n_in1 = int1%get_n_in () n_vir1 = int1%get_n_vir () n_out1 = int1%get_n_out () - n_conn n_rest(1) = n_in1 + n_vir1 + n_out1 n_in2 = int2%get_n_in () - n_conn n_vir2 = int2%get_n_vir () n_out2 = int2%get_n_out () n_rest(2) = n_in2 + n_vir2 + n_out2 n_in = n_in1 + n_in2 n_vir = n_vir1 + n_vir2 + n_conn n_out = n_out1 + n_out2 n_tot = n_in + n_vir + n_out call index_map_init (prt_map_in, n_rest) call index_map_init (prt_map_conn, n_conn) allocate (index (n_tot)) index = [ (i, i = 1, n_tot) ] prt_map_in(1)%entry(1 : n_in1) = index( 1 : n_in1) k = n_in1 prt_map_in(2)%entry(1 : n_in2) = index(k + 1 : k + n_in2) k = k + n_in2 prt_map_in(1)%entry(n_in1 + 1 : n_in1 + n_vir1) = index(k + 1 : k + n_vir1) k = k + n_vir1 prt_map_in(2)%entry(n_in2 + 1 : n_in2 + n_vir2) = index(k + 1 : k + n_vir2) k = k + n_vir2 prt_map_conn%entry = index(k + 1 : k + n_conn) k = k + n_conn prt_map_in(1)%entry(n_in1 + n_vir1 + 1 : n_rest(1)) = index(k + 1 : k + n_out1) k = k + n_out1 prt_map_in(2)%entry(n_in2 + n_vir2 + 1 : n_rest(2)) = index(k + 1 : k + n_out2) end subroutine compute_index_bounds_and_mappings subroutine connection_table_init & (connection_table, state_in1, state_in2, qn_mask_conn, & n_conn, connection_index, n_rest, & qn_filter_conn, is_real_sub) type(connection_table_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in1, state_in2 type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_conn integer, intent(in) :: n_conn integer, dimension(:,:), intent(in) :: connection_index integer, dimension(2), intent(in) :: n_rest type(quantum_numbers_t), intent(in), optional :: qn_filter_conn logical, intent(in), optional :: is_real_sub integer, dimension(2) :: n_me_in type(state_iterator_t) :: it type(quantum_numbers_t), dimension(n_conn) :: qn integer :: i, me_index_in, me_index_conn, n_me_conn integer, dimension(2) :: me_count logical :: is_sub, has_sub_qn integer :: i_beam_sub connection_table%n_conn = n_conn connection_table%n_rest = n_rest n_me_in(1) = state_in1%get_n_matrix_elements () n_me_in(2) = state_in2%get_n_matrix_elements () allocate (connection_table%index_conn (2)) call index_map_init (connection_table%index_conn, n_me_in) connection_table%index_conn = 0 call connection_table%state%init (n_counters = 2) do i = 1, 2 select case (i) case (1); call it%init (state_in1) case (2); call it%init (state_in2) end select do while (it%is_valid ()) qn = it%get_quantum_numbers (connection_index(:,i)) call qn%undefine (qn_mask_conn) if (present (qn_filter_conn)) then if (.not. all (qn .match. qn_filter_conn)) then call it%advance (); cycle end if end if call quantum_numbers_canonicalize_color (qn) me_index_in = it%get_me_index () is_sub = .false.; if (present (is_real_sub)) is_sub = is_real_sub has_sub_qn = .false. do i_beam_sub = 1, n_beam_structure_int has_sub_qn = has_sub_qn .or. any (qn%get_sub () == i_beam_sub) end do call connection_table%state%add_state (qn, & counter_index = i, & ignore_sub = .not. (is_sub .and. has_sub_qn), & me_index = me_index_conn) call index_map_set_entry (connection_table%index_conn(i), & me_index_in, me_index_conn) call it%advance () end do end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 2, 2, & it%get_quantum_numbers (), me_count, n_rest) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) type(connection_table_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) type(connection_table_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (allocated (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) write (u, *) " Input state", i do j = 1, size (connection_table%index_conn(i)) write (u, *) j, & index_map_get_entry (connection_table%index_conn(i), j) end do end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents:" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output:" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill & (connection_table, state_in1, state_in2, & connection_index, prt_is_connected) type(connection_table_t), intent(inout) :: connection_table type(state_matrix_t), intent(in), target :: state_in1, state_in2 integer, dimension(:,:), intent(in) :: connection_index type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected type(state_iterator_t) :: it integer :: index_in, index_conn integer :: color_offset integer :: n_result_entries integer :: i, k color_offset = connection_table%state%get_max_color_value () do i = 1, 2 select case (i) case (1); call it%init (state_in1) case (2); call it%init (state_in2) end select do while (it%is_valid ()) index_in = it%get_me_index () index_conn = index_map_get_entry & (connection_table%index_conn(i), index_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), i, & index_in, it%get_quantum_numbers (), & connection_index(:,i), prt_is_connected(i), & color_offset) end if call it%advance () end do color_offset = color_offset + state_in1%get_max_color_value () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + product (connection_table%entry(k)%n_index) end do call index_map_init (connection_table%index_result, n_result_entries) end subroutine connection_table_fill subroutine connection_entry_add_state & (entry, i, index_in, qn_in, connection_index, prt_is_connected, & color_offset) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: i integer, intent(in) :: index_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer, dimension(:), intent(in) :: connection_index type(prt_mask_t), intent(in) :: prt_is_connected integer, intent(in) :: color_offset integer :: c integer, dimension(:,:), allocatable :: color_map entry%count(i) = entry%count(i) + 1 c = entry%count(i) call make_color_map (color_map, & qn_in(connection_index), entry%qn_conn) call index_map_set_entry (entry%index_in(i), c, index_in) entry%qn_in_list(i)%qn(:,c) = pack (qn_in, prt_is_connected%entry) call quantum_numbers_translate_color & (entry%qn_in_list(i)%qn(:,c), color_map, color_offset) end subroutine connection_entry_add_state subroutine make_product_interaction (int, & n_in, n_vir, n_out, & connection_table, & prt_map_in, prt_is_connected, & qn_mask_in, qn_mask_conn_initial, & qn_mask_conn, qn_filter_conn, qn_mask_rest) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out type(connection_table_t), intent(inout), target :: connection_table type(index_map_t), dimension(2), intent(in) :: prt_map_in type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: & qn_mask_conn_initial type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest type(index_map_t), dimension(2) :: prt_index_in type(index_map_t) :: prt_index_conn integer :: n_tot, n_conn integer, dimension(2) :: n_rest integer :: i, j, k, m type(quantum_numbers_t), dimension(:), allocatable :: qn type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index n_conn = connection_table%n_conn n_rest = connection_table%n_rest n_tot = sum (n_rest) + n_conn allocate (qn (n_tot), qn_mask (n_tot)) do i = 1, 2 call index_map_init (prt_index_in(i), n_rest(i)) prt_index_in(i) = & prt_map_in(i)%entry ([ (j, j = 1, n_rest(i)) ]) end do call index_map_init (prt_index_conn, n_conn) prt_index_conn = prt_map_conn%entry ([ (j, j = 1, n_conn) ]) do i = 1, 2 if (present (qn_mask_rest)) then qn_mask(prt_index_in(i)%entry) = & pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) & .or. qn_mask_rest else qn_mask(prt_index_in(i)%entry) = & pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) end if end do qn_mask(prt_index_conn%entry) = qn_mask_conn_initial .or. qn_mask_conn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask = qn_mask) m = 1 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) qn(prt_index_conn%entry) = & quantum_numbers_undefined (entry%qn_conn, qn_mask_conn) if (present (qn_filter_conn)) then if (.not. all (qn(prt_index_conn%entry) .match. qn_filter_conn)) & cycle end if do j = 1, entry%n_index(1) qn(prt_index_in(1)%entry) = entry%qn_in_list(1)%qn(:,j) do k = 1, entry%n_index(2) qn(prt_index_in(2)%entry) = entry%qn_in_list(2)%qn(:,k) call int%add_state (qn, me_index = result_index) call index_map_set_entry & (connection_table%index_result, m, result_index) m = m + 1 end do end do end do call int%freeze () end subroutine make_product_interaction subroutine make_pairing_array (pa, n_matrix_elements, connection_table) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements type(connection_table_t), intent(in), target :: connection_table type(connection_entry_t), pointer :: entry integer, dimension(:), allocatable :: n_entries integer :: i, j, k, m, r allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2=.true., has_factor=.false.) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do j = 1, entry%n_index(1) do k = 1, entry%n_index(2) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 pa(r)%i1(n_entries(r)) = & index_map_get_entry (entry%index_in(1), j) pa(r)%i2(n_entries(r)) = & index_map_get_entry (entry%index_in(2), k) m = m + 1 end do end do end do end subroutine make_pairing_array subroutine record_links (int, & int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, & prt_is_connected, connections_are_resonant) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in1, int_in2 integer, dimension(:,:), intent(in) :: connection_index type(index_map_t), dimension(2), intent(in) :: prt_map_in type(index_map_t), intent(in) :: prt_map_conn type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected logical, intent(in), optional :: connections_are_resonant type(index_map_t), dimension(2) :: prt_map_all integer :: i, j, k, ival call index_map_init (prt_map_all(1), size (prt_is_connected(1))) k = 0 j = 0 do i = 1, size (prt_is_connected(1)) if (prt_is_connected(1)%entry(i)) then j = j + 1 ival = index_map_get_entry (prt_map_in(1), j) call index_map_set_entry (prt_map_all(1), i, ival) else k = k + 1 ival = index_map_get_entry (prt_map_conn, k) call index_map_set_entry (prt_map_all(1), i, ival) end if call int%set_source_link (ival, int_in1, i) end do call int_in1%transfer_relations (int, prt_map_all(1)%entry) call index_map_init (prt_map_all(2), size (prt_is_connected(2))) j = 0 do i = 1, size (prt_is_connected(2)) if (prt_is_connected(2)%entry(i)) then j = j + 1 ival = index_map_get_entry (prt_map_in(2), j) call index_map_set_entry (prt_map_all(2), i, ival) call int%set_source_link (ival, int_in2, i) else call index_map_set_entry (prt_map_all(2), i, 0) end if end do call int_in2%transfer_relations (int, prt_map_all(2)%entry) call int%relate_connections & (int_in2, connection_index(:,2), prt_map_all(2)%entry, & prt_map_conn%entry, connections_are_resonant) end subroutine record_links end subroutine evaluator_init_product @ %def evaluator_init_product @ \subsection{Creating an evaluator: square} The generic initializer for an evaluator that squares a matrix element. Depending on the provided mask, we select the appropriate specific initializer for either diagonal or non-diagonal helicity density matrices. <>= procedure :: init_square => evaluator_init_square <>= subroutine evaluator_init_square (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc if (all (qn_mask%diagonal_helicity ())) then call eval%init_square_diag (int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) else call eval%init_square_nondiag (int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) end if end subroutine evaluator_init_square @ %def evaluator_init_square @ \subsubsection{Color-summed squared matrix (diagonal helicities)} The initializer for an evaluator that squares a matrix element, including color factors. The mask must be such that off-diagonal matrix elements are excluded. If [[color_flows]] is set, the evaluator keeps color-flow entries separate and drops all interfering color structures. The color factors are set to unity in this case. There is only one input interaction. The quantum-number mask is an array, one entry for each particle, so they can be treated individually. For academic purposes, we allow for the number of colors being different from three (but 3 is the default). The algorithm is analogous to multiplication, with a few notable differences: \begin{enumerate} \item The connected particles are known, the correspondence is one-to-one. All particles are connected, and the mapping of indices is trivial, which simplifies the following steps. \item [[accumulate_connected_states]]: The matrix of connected states encompasses all particles, but color indices are removed. However, ghost states are still kept separate from physical color states. No color-index reassignment is necessary. \item The table of connections contains single index and quantum-number arrays instead of pairs of them. They are paired with themselves in all possible ways. \item [[make_squared_interaction]]: Now apply the predefined quantum-numbers mask, which usually collects all color states (physical and ghosts), and possibly a helicity sum. \item [[make_pairing_array]]: For each pair of input states, compute the color factor (including a potential ghost-parity sign) and store this in the pairing array together with the matrix-element indices for multiplication. \item [[record_links]]: This is again trivial due to the one-to-one correspondence. \end{enumerate} <>= procedure :: init_square_diag => evaluator_init_square_diag <>= subroutine evaluator_init_square_diag (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc integer :: n_in, n_vir, n_out, n_tot type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial type(state_matrix_t), pointer :: state_in type :: connection_table_t integer :: n_tot = 0 integer :: n_me_conn = 0 type(state_matrix_t) :: state type(index_map_t) :: index_conn type(connection_entry_t), dimension(:), allocatable :: entry type(index_map_t) :: index_result end type connection_table_t type(connection_table_t) :: connection_table logical :: sum_colors type(color_table_t) :: color_table if (present (expand_color_flows)) then sum_colors = .not. expand_color_flows else sum_colors = .true. end if if (sum_colors) then eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS else eval%type = EVAL_SQUARED_FLOWS end if eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_in => int_in%get_state_matrix_ptr () allocate (qn_mask_initial (n_tot)) qn_mask_initial = int_in%get_mask () call qn_mask_initial%set_color (sum_colors, mask_cg=.false.) if (sum_colors) then call color_table_init (color_table, state_in, n_tot) if (present (col_flow_index) .and. present (col_factor) & .and. present (col_index_hi)) then call color_table_set_color_factors & (color_table, col_flow_index, col_factor, col_index_hi) end if end if call connection_table_init (connection_table, state_in, & qn_mask_initial, qn_mask, n_tot) call connection_table_fill (connection_table, state_in) call make_squared_interaction (eval%interaction_t, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask_initial .or. qn_mask) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table, sum_colors, color_table, n_in, n_tot, nc) call record_links (eval, int_in, n_tot) call connection_table_final (connection_table) contains subroutine connection_table_init & (connection_table, state_in, qn_mask_in, qn_mask, n_tot) type(connection_table_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, intent(in) :: n_tot type(quantum_numbers_t), dimension(n_tot) :: qn type(state_iterator_t) :: it integer :: i, n_me_in, me_index_in integer :: me_index_conn, n_me_conn integer, dimension(1) :: me_count logical :: qn_passed connection_table%n_tot = n_tot n_me_in = state_in%get_n_matrix_elements () call index_map_init (connection_table%index_conn, n_me_in) connection_table%index_conn = 0 call connection_table%state%init (n_counters=1) call it%init (state_in) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (all (quantum_numbers_are_physical (qn, qn_mask))) then call qn%undefine (qn_mask_in) qn_passed = .true. if (qn_passed) then me_index_in = it%get_me_index () call connection_table%state%add_state (qn, & counter_index = 1, me_index = me_index_conn) call index_map_set_entry (connection_table%index_conn, & me_index_in, me_index_conn) end if end if call it%advance () end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 1, 2, & it%get_quantum_numbers (), me_count, [n_tot]) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) type(connection_table_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) type(connection_table_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (index_map_exists (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) write (u, *) i, & index_map_get_entry (connection_table%index_conn, i) end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill (connection_table, state) type(connection_table_t), intent(inout) :: connection_table type(state_matrix_t), intent(in), target :: state integer :: index_in, index_conn, n_result_entries type(state_iterator_t) :: it integer :: k call it%init (state) do while (it%is_valid ()) index_in = it%get_me_index () index_conn = & index_map_get_entry (connection_table%index_conn, index_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), & index_in, it%get_quantum_numbers ()) end if call it%advance () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + connection_table%entry(k)%n_index(1) ** 2 end do call index_map_init (connection_table%index_result, n_result_entries) connection_table%index_result = 0 end subroutine connection_table_fill subroutine connection_entry_add_state (entry, index_in, qn_in) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: index_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer :: c entry%count = entry%count + 1 c = entry%count(1) call index_map_set_entry (entry%index_in(1), c, index_in) entry%qn_in_list(1)%qn(:,c) = qn_in end subroutine connection_entry_add_state subroutine make_squared_interaction (int, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out, n_tot type(connection_table_t), intent(inout), target :: connection_table logical, intent(in) :: sum_colors type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index, n_contrib integer :: i, m type(quantum_numbers_t), dimension(n_tot) :: qn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask) m = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) qn = quantum_numbers_undefined (entry%qn_conn, qn_mask) if (.not. sum_colors) call qn(1:n_in)%invert_color () call int%add_state (qn, me_index = result_index) n_contrib = entry%n_index(1) ** 2 connection_table%index_result%entry(m+1:m+n_contrib) = result_index m = m + n_contrib end do call int%freeze () end subroutine make_squared_interaction subroutine make_pairing_array (pa, & n_matrix_elements, connection_table, sum_colors, color_table, & n_in, n_tot, nc) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements type(connection_table_t), intent(in), target :: connection_table logical, intent(in) :: sum_colors type(color_table_t), intent(inout) :: color_table type(connection_entry_t), pointer :: entry integer, intent(in) :: n_in, n_tot integer, intent(in), optional :: nc integer, dimension(:), allocatable :: n_entries integer :: i, k, l, ks, ls, m, r integer :: color_multiplicity_in allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, entry%n_index(1) if (sum_colors) then color_multiplicity_in = & product (abs (quantum_numbers_get_color_type & (entry%qn_in_list(1)%qn(:n_in, k)))) do l = 1, entry%n_index(1) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 ks = index_map_get_entry (entry%index_in(1), k) ls = index_map_get_entry (entry%index_in(1), l) pa(r)%i1(n_entries(r)) = ks pa(r)%i2(n_entries(r)) = ls pa(r)%factor(n_entries(r)) = & color_table_get_color_factor (color_table, ks, ls, nc) & / color_multiplicity_in m = m + 1 end do else r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 ks = index_map_get_entry (entry%index_in(1), k) pa(r)%i1(n_entries(r)) = ks m = m + 1 end if end do end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_square_diag @ %def evaluator_init_square_diag @ \subsubsection{Color-summed squared matrix (support nodiagonal helicities)} The initializer for an evaluator that squares a matrix element, including color factors. Unless requested otherwise by the quantum-number mask, the result contains off-diagonal matrix elements. (The input interaction must be diagonal since it represents an amplitude, not a density matrix.) There is only one input interaction. The quantum-number mask is an array, one entry for each particle, so they can be treated individually. For academic purposes, we allow for the number of colors being different from three (but 3 is the default). The algorithm is analogous to the previous one, with some additional complications due to the necessity to loop over two helicity indices. <>= procedure :: init_square_nondiag => evaluator_init_square_nondiag <>= subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc integer :: n_in, n_vir, n_out, n_tot type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial type(state_matrix_t), pointer :: state_in type :: connection_table_t integer :: n_tot = 0 integer :: n_me_conn = 0 type(state_matrix_t) :: state type(index_map2_t) :: index_conn type(connection_entry_t), dimension(:), allocatable :: entry type(index_map_t) :: index_result end type connection_table_t type(connection_table_t) :: connection_table logical :: sum_colors type(color_table_t) :: color_table if (present (expand_color_flows)) then sum_colors = .not. expand_color_flows else sum_colors = .true. end if if (sum_colors) then eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS else eval%type = EVAL_SQUARED_FLOWS end if eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_in => int_in%get_state_matrix_ptr () allocate (qn_mask_initial (n_tot)) qn_mask_initial = int_in%get_mask () call qn_mask_initial%set_color (sum_colors, mask_cg=.false.) if (sum_colors) then call color_table_init (color_table, state_in, n_tot) if (present (col_flow_index) .and. present (col_factor) & .and. present (col_index_hi)) then call color_table_set_color_factors & (color_table, col_flow_index, col_factor, col_index_hi) end if end if call connection_table_init (connection_table, state_in, & qn_mask_initial, qn_mask, n_tot) call connection_table_fill (connection_table, state_in) call make_squared_interaction (eval%interaction_t, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask_initial .or. qn_mask) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table, sum_colors, color_table, n_in, n_tot, nc) call record_links (eval, int_in, n_tot) call connection_table_final (connection_table) contains subroutine connection_table_init & (connection_table, state_in, qn_mask_in, qn_mask, n_tot) type(connection_table_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, intent(in) :: n_tot type(quantum_numbers_t), dimension(n_tot) :: qn1, qn2, qn type(state_iterator_t) :: it1, it2, it integer :: i, n_me_in, me_index_in1, me_index_in2 integer :: me_index_conn, n_me_conn integer, dimension(1) :: me_count logical :: qn_passed connection_table%n_tot = n_tot n_me_in = state_in%get_n_matrix_elements () call index_map2_init (connection_table%index_conn, n_me_in) connection_table%index_conn = 0 call connection_table%state%init (n_counters=1) call it1%init (state_in) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () me_index_in1 = it1%get_me_index () call it2%init (state_in) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () if (all (quantum_numbers_are_compatible (qn1, qn2, qn_mask))) then qn = qn1 .merge. qn2 call qn%undefine (qn_mask_in) qn_passed = .true. if (qn_passed) then me_index_in2 = it2%get_me_index () call connection_table%state%add_state (qn, & counter_index = 1, me_index = me_index_conn) call index_map2_set_entry (connection_table%index_conn, & me_index_in1, me_index_in2, me_index_conn) end if end if call it2%advance () end do call it1%advance () end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 1, 2, & it%get_quantum_numbers (), me_count, [n_tot]) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) type(connection_table_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) type(connection_table_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (index_map2_exists (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) do j = 1, size (connection_table%index_conn) write (u, *) i, j, & index_map2_get_entry (connection_table%index_conn, i, j) end do end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill (connection_table, state) type(connection_table_t), intent(inout), target :: connection_table type(state_matrix_t), intent(in), target :: state integer :: index1_in, index2_in, index_conn, n_result_entries type(state_iterator_t) :: it1, it2 integer :: k call it1%init (state) do while (it1%is_valid ()) index1_in = it1%get_me_index () call it2%init (state) do while (it2%is_valid ()) index2_in = it2%get_me_index () index_conn = index_map2_get_entry & (connection_table%index_conn, index1_in, index2_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), & index1_in, index2_in, & it1%get_quantum_numbers () & .merge. & it2%get_quantum_numbers ()) end if call it2%advance () end do call it1%advance () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + connection_table%entry(k)%n_index(1) end do call index_map_init (connection_table%index_result, n_result_entries) connection_table%index_result = 0 end subroutine connection_table_fill subroutine connection_entry_add_state (entry, index1_in, index2_in, qn_in) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: index1_in, index2_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer :: c entry%count = entry%count + 1 c = entry%count(1) call index_map_set_entry (entry%index_in(1), c, index1_in) call index_map_set_entry (entry%index_in(2), c, index2_in) entry%qn_in_list(1)%qn(:,c) = qn_in end subroutine connection_entry_add_state subroutine make_squared_interaction (int, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out, n_tot type(connection_table_t), intent(inout), target :: connection_table logical, intent(in) :: sum_colors type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index integer :: i, k, m type(quantum_numbers_t), dimension(n_tot) :: qn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask) m = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, size (entry%qn_in_list(1)%qn, 2) qn = quantum_numbers_undefined & (entry%qn_in_list(1)%qn(:,k), qn_mask) if (.not. sum_colors) call qn(1:n_in)%invert_color () call int%add_state (qn, me_index = result_index) call index_map_set_entry (connection_table%index_result, m + 1, & result_index) m = m + 1 end do end do call int%freeze () end subroutine make_squared_interaction subroutine make_pairing_array (pa, & n_matrix_elements, connection_table, sum_colors, color_table, & n_in, n_tot, nc) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements type(connection_table_t), intent(in), target :: connection_table logical, intent(in) :: sum_colors type(color_table_t), intent(inout) :: color_table type(connection_entry_t), pointer :: entry integer, intent(in) :: n_in, n_tot integer, intent(in), optional :: nc integer, dimension(:), allocatable :: n_entries integer :: i, k, k1s, k2s, m, r integer :: color_multiplicity_in allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, entry%n_index(1) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 if (sum_colors) then k1s = index_map_get_entry (entry%index_in(1), k) k2s = index_map_get_entry (entry%index_in(2), k) pa(r)%i1(n_entries(r)) = k1s pa(r)%i2(n_entries(r)) = k2s color_multiplicity_in = & product (abs (quantum_numbers_get_color_type & (entry%qn_in_list(1)%qn(:n_in, k)))) pa(r)%factor(n_entries(r)) = & color_table_get_color_factor (color_table, k1s, k2s, nc) & / color_multiplicity_in else k1s = index_map_get_entry (entry%index_in(1), k) pa(r)%i1(n_entries(r)) = k1s end if m = m + 1 end do end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_square_nondiag @ %def evaluator_init_square_nondiag @ \subsubsection{Copy with additional contracted color states} This evaluator involves no square or multiplication, its matrix elements are just copies of the (single) input interaction. However, the state matrix of the interaction contains additional states that have color indices contracted. This is used for copies of the beam or structure-function interactions that need to match the hard interaction also in the case where its color indices coincide. <>= procedure :: init_color_contractions => evaluator_init_color_contractions <>= subroutine evaluator_init_color_contractions (eval, int_in) class(evaluator_t), intent(out), target :: eval type(interaction_t), intent(in), target :: int_in integer :: n_in, n_vir, n_out, n_tot type(state_matrix_t) :: state_with_contractions integer, dimension(:), allocatable :: me_index integer, dimension(:), allocatable :: result_index eval%type = EVAL_COLOR_CONTRACTION eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_with_contractions = int_in%get_state_matrix_ptr () call state_with_contractions%add_color_contractions () call make_contracted_interaction (eval%interaction_t, & me_index, result_index, & n_in, n_vir, n_out, n_tot, & state_with_contractions, int_in%get_mask ()) call make_pairing_array (eval%pairing_array, me_index, result_index) call record_links (eval, int_in, n_tot) call state_with_contractions%final () contains subroutine make_contracted_interaction (int, & me_index, result_index, & n_in, n_vir, n_out, n_tot, state, qn_mask) type(interaction_t), intent(out), target :: int integer, dimension(:), intent(out), allocatable :: me_index integer, dimension(:), intent(out), allocatable :: result_index integer, intent(in) :: n_in, n_vir, n_out, n_tot type(state_matrix_t), intent(in) :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(state_iterator_t) :: it integer :: n_me, i type(quantum_numbers_t), dimension(n_tot) :: qn call int%basic_init (n_in, n_vir, n_out, mask=qn_mask) n_me = state%get_n_leaves () allocate (me_index (n_me)) allocate (result_index (n_me)) call it%init (state) i = 0 do while (it%is_valid ()) i = i + 1 me_index(i) = it%get_me_index () qn = it%get_quantum_numbers () call int%add_state (qn, me_index = result_index(i)) call it%advance () end do call int%freeze () end subroutine make_contracted_interaction subroutine make_pairing_array (pa, me_index, result_index) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, dimension(:), intent(in) :: me_index, result_index integer, dimension(:), allocatable :: n_entries integer :: n_matrix_elements, r, i n_matrix_elements = size (me_index) allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 1 call pairing_array_init & (pa, n_entries, has_i2=.false., has_factor=.false.) do i = 1, n_matrix_elements r = result_index(i) pa(r)%i1(1) = me_index(i) end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_color_contractions @ %def evaluator_init_color_contractions @ \subsubsection{Auxiliary procedure for initialization} This will become a standard procedure in F2008. The result is true if the number of true values in the mask is odd. We use the function for determining the ghost parity of a quantum-number array. [tho:] It's not used anymore and [[mod (count (mask), 2) == 1]] is a cooler implementation anyway. <<(UNUSED) Evaluators: procedures>>= function parity (mask) logical :: parity logical, dimension(:) :: mask integer :: i parity = .false. do i = 1, size (mask) if (mask(i)) parity = .not. parity end do end function parity @ %def parity @ Reassign external source links from one to another. <>= public :: evaluator_reassign_links <>= interface evaluator_reassign_links module procedure evaluator_reassign_links_eval module procedure evaluator_reassign_links_int end interface <>= subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target) type(evaluator_t), intent(inout) :: eval type(evaluator_t), intent(in) :: eval_src type(evaluator_t), intent(in), target :: eval_target if (associated (eval%int_in1)) then if (eval%int_in1%get_tag () == eval_src%get_tag ()) then eval%int_in1 => eval_target%interaction_t end if end if if (associated (eval%int_in2)) then if (eval%int_in2%get_tag () == eval_src%get_tag ()) then eval%int_in2 => eval_target%interaction_t end if end if call interaction_reassign_links & (eval%interaction_t, eval_src%interaction_t, & eval_target%interaction_t) end subroutine evaluator_reassign_links_eval subroutine evaluator_reassign_links_int (eval, int_src, int_target) type(evaluator_t), intent(inout) :: eval type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target if (associated (eval%int_in1)) then if (eval%int_in1%get_tag () == int_src%get_tag ()) then eval%int_in1 => int_target end if end if if (associated (eval%int_in2)) then if (eval%int_in2%get_tag () == int_src%get_tag ()) then eval%int_in2 => int_target end if end if call interaction_reassign_links (eval%interaction_t, int_src, int_target) end subroutine evaluator_reassign_links_int @ %def evaluator_reassign_links @ Return flavor, momentum, and position of the first unstable particle present in the interaction. <>= public :: evaluator_get_unstable_particle <>= subroutine evaluator_get_unstable_particle (eval, flv, p, i) type(evaluator_t), intent(in) :: eval type(flavor_t), intent(out) :: flv type(vector4_t), intent(out) :: p integer, intent(out) :: i call interaction_get_unstable_particle (eval%interaction_t, flv, p, i) end subroutine evaluator_get_unstable_particle @ %def evaluator_get_unstable_particle @ <>= public :: evaluator_get_int_in_ptr <>= function evaluator_get_int_in_ptr (eval, i) result (int_in) class(interaction_t), pointer :: int_in type(evaluator_t), intent(in), target :: eval integer, intent(in) :: i if (i == 1) then int_in => eval%int_in1 else if (i == 2) then int_in => eval%int_in2 else int_in => null () end if end function evaluator_get_int_in_ptr @ %def evaluator_get_int_in_ptr @ \subsection{Creating an evaluator: identity} The identity evaluator creates a copy of the first input evaluator; the second input is not used. All particles link back to the input evaluatorand the internal relations are copied. As evaluation does take a shortcut by cloning the matrix elements, the pairing array is not used and does not have to be set up. <>= procedure :: init_identity => evaluator_init_identity <>= subroutine evaluator_init_identity (eval, int) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int integer :: n_in, n_out, n_vir, n_tot integer :: i integer, dimension(:), allocatable :: map type(state_matrix_t), pointer :: state type(state_iterator_t) :: it eval%type = EVAL_IDENTITY eval%int_in1 => int nullify (eval%int_in2) n_in = int%get_n_in () n_out = int%get_n_out () n_vir = int%get_n_vir () n_tot = int%get_n_tot () call eval%interaction_t%basic_init (n_in, n_vir, n_out, & mask = int%get_mask (), & resonant = int%get_resonance_flags ()) do i = 1, n_tot call eval%set_source_link (i, int, i) end do allocate (map(n_tot)) map = [(i, i = 1, n_tot)] call int%transfer_relations (eval, map) state => int%get_state_matrix_ptr () call it%init (state) do while (it%is_valid ()) call eval%add_state (it%get_quantum_numbers (), & it%get_me_index ()) call it%advance () end do call eval%freeze () end subroutine evaluator_init_identity @ %def evaluator_init_identity @ \subsection {Creating an evaluator: quantum number sum} This evaluator operates on the diagonal of a density matrix and sums over the quantum numbers specified by the mask. The optional argument [[drop]] allows to drop a particle from the resulting density matrix. The handling of virtuals is not completely sane, especially in connection with dropping particles. When summing over matrix element entries, we keep the separation into entries and normalization (in the corresponding evaluation routine below). <>= procedure :: init_qn_sum => evaluator_init_qn_sum <>= subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop) class(evaluator_t), intent(out), target :: eval class(interaction_t), target, intent(in) :: int type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask logical, intent(in), optional, dimension(:) :: drop type(state_iterator_t) :: it_old, it_new integer, dimension(:), allocatable :: pairing_size, pairing_target, i_new integer, dimension(:), allocatable :: map integer :: n_in, n_out, n_vir, n_tot, n_me_old, n_me_new integer :: i, j type(state_matrix_t), pointer :: state_new, state_old type(quantum_numbers_t), dimension(:), allocatable :: qn logical :: matched logical, dimension(size (qn_mask)) :: dropped integer :: ndropped integer, dimension(:), allocatable :: inotdropped type(quantum_numbers_mask_t), dimension(:), allocatable :: mask logical, dimension(:), allocatable :: resonant eval%type = EVAL_QN_SUM eval%int_in1 => int nullify (eval%int_in2) if (present (drop)) then dropped = drop else dropped = .false. end if ndropped = count (dropped) n_in = int%get_n_in () n_out = int%get_n_out () - ndropped n_vir = int%get_n_vir () n_tot = int%get_n_tot () - ndropped allocate (inotdropped (n_tot)) i = 1 do j = 1, n_tot + ndropped if (dropped (j)) cycle inotdropped(i) = j i = i + 1 end do allocate (mask(n_tot + ndropped)) mask = int%get_mask () allocate (resonant(n_tot + ndropped)) resonant = int%get_resonance_flags () call eval%interaction_t%basic_init (n_in, n_vir, n_out, & mask = mask(inotdropped) .or. qn_mask(inotdropped), & resonant = resonant(inotdropped)) i = 1 do j = 1, n_tot + ndropped if (dropped(j)) cycle call eval%set_source_link (i, int, j) i = i + 1 end do allocate (map(n_tot + ndropped)) i = 1 do j = 1, n_tot + ndropped if (dropped (j)) then map(j) = 0 else map(j) = i i = i + 1 end if end do call int%transfer_relations (eval, map) n_me_old = int%get_n_matrix_elements () allocate (pairing_size (n_me_old), source = 0) allocate (pairing_target (n_me_old), source = 0) pairing_size = 0 state_old => int%get_state_matrix_ptr () state_new => eval%get_state_matrix_ptr () call it_old%init (state_old) allocate (qn(n_tot + ndropped)) do while (it_old%is_valid ()) qn = it_old%get_quantum_numbers () if (.not. all (qn%are_diagonal ())) then call it_old%advance () cycle end if matched = .false. call it_new%init (state_new) if (eval%get_n_matrix_elements () > 0) then do while (it_new%is_valid ()) if (all (qn(inotdropped) .match. & it_new%get_quantum_numbers ())) & then matched = .true. i = it_new%get_me_index () exit end if call it_new%advance () end do end if if (.not. matched) then call eval%add_state (qn(inotdropped)) i = eval%get_n_matrix_elements () end if pairing_size(i) = pairing_size(i) + 1 pairing_target(it_old%get_me_index ()) = i call it_old%advance () end do call eval%freeze () n_me_new = eval%get_n_matrix_elements () allocate (eval%pairing_array (n_me_new)) do i = 1, n_me_new call pairing_array_init (eval%pairing_array(i), & pairing_size(i), .false., .false.) end do allocate (i_new (n_me_new), source = 0) do i = 1, n_me_old j = pairing_target(i) if (j > 0) then i_new(j) = i_new(j) + 1 eval%pairing_array(j)%i1(i_new(j)) = i end if end do end subroutine evaluator_init_qn_sum @ %def evaluator_init_qn_sum @ \subsection{Evaluation} When the input interactions (which are pointed to in the pairings stored within the evaluator) are filled with values, we can activate the evaluator, i.e., calculate the result values which are stored in the interaction. The evaluation of matrix elements can be done in parallel. A [[forall]] construct is not appropriate, however. We would need [[do concurrent]] here. Nevertheless, the evaluation functions are marked as [[pure]]. <>= procedure :: evaluate => evaluator_evaluate <>= subroutine evaluator_evaluate (eval) class(evaluator_t), intent(inout), target :: eval integer :: i select case (eval%type) case (EVAL_PRODUCT) do i = 1, size(eval%pairing_array) call eval%evaluate_product (i, & eval%int_in1, eval%int_in2, & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2) if (debug2_active (D_QFT)) then print *, 'eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 = ', & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 print *, 'MEs = ', & eval%int_in1%get_matrix_element (eval%pairing_array(i)%i1), & eval%int_in2%get_matrix_element (eval%pairing_array(i)%i2) end if end do case (EVAL_SQUARE_WITH_COLOR_FACTORS) do i = 1, size(eval%pairing_array) call eval%evaluate_product_cf (i, & eval%int_in1, eval%int_in1, & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2, & eval%pairing_array(i)%factor) end do case (EVAL_SQUARED_FLOWS) do i = 1, size(eval%pairing_array) call eval%evaluate_square_c (i, & eval%int_in1, & eval%pairing_array(i)%i1) end do case (EVAL_COLOR_CONTRACTION) do i = 1, size(eval%pairing_array) call eval%evaluate_sum (i, & eval%int_in1, & eval%pairing_array(i)%i1) end do case (EVAL_IDENTITY) call eval%set_matrix_element (eval%int_in1) case (EVAL_QN_SUM) do i = 1, size (eval%pairing_array) call eval%evaluate_me_sum (i, & eval%int_in1, eval%pairing_array(i)%i1) call eval%set_norm (eval%int_in1%get_norm ()) end do end select end subroutine evaluator_evaluate @ %def evaluator_evaluate @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[evaluators_ut.f90]]>>= <> module evaluators_ut use unit_tests use evaluators_uti <> <> contains <> end module evaluators_ut @ %def evaluators_ut @ <<[[evaluators_uti.f90]]>>= <> module evaluators_uti <> use lorentz use flavors use colors use helicities use quantum_numbers use interactions use model_data use evaluators <> <> contains <> end module evaluators_uti @ %def evaluators_ut @ API: driver for the unit tests below. <>= public :: evaluator_test <>= subroutine evaluator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine evaluator_test @ %def evaluator_test @ Test: Create two interactions. The interactions are twofold connected. The first connection has a helicity index that is kept, the second connection has a helicity index that is summed over. Concatenate the interactions in an evaluator, which thus contains a result interaction. Fill the input interactions with values, activate the evaluator and print the result. <>= call test (evaluator_1, "evaluator_1", & "check evaluators (1)", & u, results) <>= public :: evaluator_1 <>= subroutine evaluator_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int_qqtt, int_tbw, int1, int2 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 integer :: f, c, h1, h2, h3 type(vector4_t), dimension(4) :: p type(vector4_t), dimension(2) :: q type(quantum_numbers_mask_t) :: qn_mask_conn type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask2 type(evaluator_t), target :: eval, eval2, eval3 call model%init_sm_test () write (u, "(A)") "*** Evaluator for matrix product" write (u, "(A)") "*** Construct interaction for qq -> tt" write (u, "(A)") call int_qqtt%basic_init (2, 0, 2, set_relations=.true.) allocate (flv (4), col (4), hel (4), qn (4)) allocate (qn_mask2 (4)) do c = 1, 2 select case (c) case (1) call col%init_col_acl ([1, 0, 1, 0], [0, 2, 0, 2]) case (2) call col%init_col_acl ([1, 0, 2, 0], [0, 1, 0, 2]) end select do f = 1, 2 call flv%init ([f, -f, 6, -6], model) do h1 = -1, 1, 2 call hel(3)%init (h1) do h2 = -1, 1, 2 call hel(4)%init (h2) call qn%init (flv, col, hel) call int_qqtt%add_state (qn) end do end do end do end do call int_qqtt%freeze () deallocate (flv, col, hel, qn) write (u, "(A)") "*** Construct interaction for t -> bW" call int_tbw%basic_init (1, 0, 2, set_relations=.true.) allocate (flv (3), col (3), hel (3), qn (3)) call flv%init ([6, 5, 24], model) call col%init_col_acl ([1, 1, 0], [0, 0, 0]) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) call qn%init (flv, col, hel) call int_tbw%add_state (qn) end do end do end do call int_tbw%freeze () deallocate (flv, col, hel, qn) write (u, "(A)") "*** Link interactions" call int_tbw%set_source_link (1, int_qqtt, 3) qn_mask_conn = quantum_numbers_mask (.false.,.false.,.true.) write (u, "(A)") write (u, "(A)") "*** Show input" call int_qqtt%basic_write (unit = u) write (u, "(A)") call int_tbw%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*** Evaluate product" call eval%init_product (int_qqtt, int_tbw, qn_mask_conn) call eval%write (unit = u) call int1%basic_init (2, 0, 2, set_relations=.true.) call int2%basic_init (1, 0, 2, set_relations=.true.) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (200._default, 200._default, 2) p(3) = vector4_moving (100._default, 200._default, 1) p(4) = p(1) - p(2) - p(3) call int1%set_momenta (p) q(1) = vector4_moving (50._default,-50._default, 3) q(2) = p(2) + p(4) - q(1) call int2%set_momenta (q, outgoing=.true.) call int1%set_matrix_element ([(2._default,0._default), & (4._default,1._default), (-3._default,0._default)]) call int2%set_matrix_element ([(-3._default,0._default), & (0._default,1._default), (1._default,2._default)]) call eval%receive_momenta () call eval%evaluate () call int1%basic_write (unit = u) write (u, "(A)") call int2%basic_write (unit = u) write (u, "(A)") call eval%write (unit = u) write (u, "(A)") call int1%final () call int2%final () call eval%final () write (u, "(A)") write (u, "(A)") "*** Evaluator for matrix square" allocate (flv(4), col(4), qn(4)) call int1%basic_init (2, 0, 2, set_relations=.true.) call flv%init ([1, -1, 21, 21], model) call col(1)%init ([1]) call col(2)%init ([-2]) call col(3)%init ([2, -3]) call col(4)%init ([3, -1]) call qn%init (flv, col) call int1%add_state (qn) call col(3)%init ([3, -1]) call col(4)%init ([2, -3]) call qn%init (flv, col) call int1%add_state (qn) call col(3)%init ([2, -1]) call col(4)%init (.true.) call qn%init (flv, col) call int1%add_state (qn) call int1%freeze () ! [qn_mask2 not set since default is false] call eval%init_square (int1, qn_mask2, nc=3) call eval2%init_square_nondiag (int1, qn_mask2) qn_mask2 = quantum_numbers_mask (.false., .true., .true.) call eval3%init_square_diag (eval, qn_mask2) call int1%set_matrix_element & ([(2._default,0._default), & (4._default,1._default), (-3._default,0._default)]) call int1%set_momenta (p) call int1%basic_write (unit = u) write (u, "(A)") call eval%receive_momenta () call eval%evaluate () call eval%write (unit = u) write (u, "(A)") call eval2%receive_momenta () call eval2%evaluate () call eval2%write (unit = u) write (u, "(A)") call eval3%receive_momenta () call eval3%evaluate () call eval3%write (unit = u) call int1%final () call eval%final () call eval2%final () call eval3%final () call model%final () end subroutine evaluator_1 @ %def evaluator_1 @ <>= call test (evaluator_2, "evaluator_2", & "check evaluators (2)", & u, results) <>= public :: evaluator_2 <>= subroutine evaluator_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int integer :: h1, h2, h3, h4 type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(flavor_t), dimension(4) :: flv type(quantum_numbers_t), dimension(4) :: qn type(vector4_t), dimension(4) :: p type(evaluator_t) :: eval integer :: i call model%init_sm_test () write (u, "(A)") "*** Creating interaction for e+ e- -> W+ W-" write (u, "(A)") call flv%init ([11, -11, 24, -24], model) do i = 1, 4 call col(i)%init () end do call int%basic_init (2, 0, 2, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) do h4 = -1, 1 call hel(4)%init (h4) call qn%init (flv, col, hel) call int%add_state (qn) end do end do end do end do call int%freeze () call int%set_matrix_element & ([(cmplx (i, kind=default), i = 1, 36)]) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (1000._default, -1000._default, 3) p(3) = vector4_moving (1000._default, & sqrt (1E6_default - 80._default**2), 3) p(4) = p(1) + p(2) - p(3) call int%set_momenta (p) write (u, "(A)") "*** Setting up evaluator" write (u, "(A)") call eval%init_identity (int) write (u, "(A)") "*** Transferring momenta and evaluating" write (u, "(A)") call eval%receive_momenta () call eval%evaluate () write (u, "(A)") "*******************************************************" write (u, "(A)") " Interaction dump" write (u, "(A)") "*******************************************************" call int%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump" write (u, "(A)") "*******************************************************" call eval%write (unit = u) write (u, "(A)") write (u, "(A)") "*** cleaning up" call int%final () call eval%final () call model%final () end subroutine evaluator_2 @ %def evaluator_2 @ <>= call test (evaluator_3, "evaluator_3", & "check evaluators (3)", & u, results) <>= public :: evaluator_3 <>= subroutine evaluator_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int integer :: h1, h2, h3, h4 type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(flavor_t), dimension(4) :: flv1, flv2 type(quantum_numbers_t), dimension(4) :: qn type(vector4_t), dimension(4) :: p type(evaluator_t) :: eval1, eval2, eval3 type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: i call model%init_sm_test () write (u, "(A)") "*** Creating interaction for e+/mu+ e-/mu- -> W+ W-" call flv1%init ([11, -11, 24, -24], model) call flv2%init ([13, -13, 24, -24], model) do i = 1, 4 call col (i)%init () end do call int%basic_init (2, 0, 2, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) do h4 = -1, 1 call hel(4)%init (h4) call qn%init (flv1, col, hel) call int%add_state (qn) call qn%init (flv2, col, hel) call int%add_state (qn) end do end do end do end do call int%freeze () call int%set_matrix_element & ([(cmplx (1, kind=default), i = 1, 72)]) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (1000._default, -1000._default, 3) p(3) = vector4_moving (1000._default, & sqrt (1E6_default - 80._default**2), 3) p(4) = p(1) + p(2) - p(3) call int%set_momenta (p) write (u, "(A)") "*** Setting up evaluators" call qn_mask%init (.false., .true., .true.) call eval1%init_qn_sum (int, qn_mask) call qn_mask%init (.true., .true., .true.) call eval2%init_qn_sum (int, qn_mask) call qn_mask%init (.false., .true., .false.) call eval3%init_qn_sum (int, qn_mask, & [.false., .false., .false., .true.]) write (u, "(A)") "*** Transferring momenta and evaluating" call eval1%receive_momenta () call eval1%evaluate () call eval2%receive_momenta () call eval2%evaluate () call eval3%receive_momenta () call eval3%evaluate () write (u, "(A)") "*******************************************************" write (u, "(A)") " Interaction dump" write (u, "(A)") "*******************************************************" call int%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- spin sum" write (u, "(A)") "*******************************************************" call eval1%write (unit = u) call eval1%basic_write (unit = u) write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- spin / flavor sum" write (u, "(A)") "*******************************************************" call eval2%write (unit = u) call eval2%basic_write (unit = u) write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- flavor sum, drop last W" write (u, "(A)") "*******************************************************" call eval3%write (unit = u) call eval3%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*** cleaning up" call int%final () call eval1%final () call eval2%final () call eval3%final () call model%final () end subroutine evaluator_3 @ %def evaluator_3 @ This test evaluates a product with different quantum-number masks and filters for the linked entry. <>= call test (evaluator_4, "evaluator_4", & "check evaluator product with filter", & u, results) <>= public :: evaluator_4 <>= subroutine evaluator_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int1, int2 integer :: h1, h2, h3 type(helicity_t), dimension(3) :: hel type(color_t), dimension(3) :: col type(flavor_t), dimension(2) :: flv1, flv2 type(flavor_t), dimension(3) :: flv3, flv4 type(quantum_numbers_t), dimension(3) :: qn type(evaluator_t) :: eval1, eval2, eval3, eval4 type(quantum_numbers_mask_t) :: qn_mask type(flavor_t) :: flv_filter type(helicity_t) :: hel_filter type(color_t) :: col_filter type(quantum_numbers_t) :: qn_filter integer :: i write (u, "(A)") "* Test output: evaluator_4" write (u, "(A)") "* Purpose: test evaluator products & &with mask and filter" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Creating interaction for e- -> W+/Z" write (u, "(A)") call flv1%init ([11, 24], model) call flv2%init ([11, 23], model) do i = 1, 3 call col(i)%init () end do call int1%basic_init (1, 0, 1, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1 call hel(2)%init (h2) call qn(:2)%init (flv1, col(:2), hel(:2)) call int1%add_state (qn(:2)) call qn(:2)%init (flv2, col(:2), hel(:2)) call int1%add_state (qn(:2)) end do end do call int1%freeze () call int1%basic_write (u) write (u, "(A)") write (u, "(A)") "* Creating interaction for W+/Z -> u ubar/dbar" write (u, "(A)") call flv3%init ([24, 2, -1], model) call flv4%init ([23, 2, -2], model) call int2%basic_init (1, 0, 2, set_relations=.true.) do h1 = -1, 1 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1, 2 call hel(3)%init (h3) call qn(:3)%init (flv3, col(:3), hel(:3)) call int2%add_state (qn(:3)) call qn(:3)%init (flv4, col(:3), hel(:3)) call int2%add_state (qn(:3)) end do end do end do call int2%freeze () call int2%set_source_link (1, int1, 2) call int2%basic_write (u) write (u, "(A)") write (u, "(A)") "* Product evaluator" write (u, "(A)") call qn_mask%init (.false., .false., .false.) call eval1%init_product (int1, int2, qn_mask_conn = qn_mask) call eval1%write (u) write (u, "(A)") write (u, "(A)") "* Product evaluator with helicity mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call eval2%init_product (int1, int2, qn_mask_conn = qn_mask) call eval2%write (u) write (u, "(A)") write (u, "(A)") "* Product with flavor filter and helicity mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call flv_filter%init (24, model) call hel_filter%init () call col_filter%init () call qn_filter%init (flv_filter, col_filter, hel_filter) call eval3%init_product (int1, int2, & qn_mask_conn = qn_mask, qn_filter_conn = qn_filter) call eval3%write (u) write (u, "(A)") write (u, "(A)") "* Product with helicity filter and mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call flv_filter%init () call hel_filter%init (0) call col_filter%init () call qn_filter%init (flv_filter, col_filter, hel_filter) call eval4%init_product (int1, int2, & qn_mask_conn = qn_mask, qn_filter_conn = qn_filter) call eval4%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eval1%final () call eval2%final () call eval3%final () call eval4%final () call int1%final () call int2%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: evaluator_4" end subroutine evaluator_4 @ %def evaluator_4