diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..0480549 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,182 @@ +2006-05-11 Gavin Salam + + * fixed another bug in sort routine (didn't seem to affect + results, but was dodgy anyway). + +2006-05-10 Gavin SALAM + + * fixed bug in sort routine; more to come... + * added various facilities to tests/determine_accuracies.f90 + (but probably needs more work) (still need to add dy_min?) + + * Changed some more names (ev_Setdu -> SetDefaultEvolutionDu) + * Allowed eps to be made an argument of a grid initialisation + * Introduced query functions for eps and du + (DefaultConvolutionEps, DefaultEvolutionDu) + * Introduced GetGridInfoString(grid,string) to get a + description string for one's run... + + * Changed default global access to be via hoppet_v1 module + * Changed default Qmax in f77_pdftab to 28TeV (2*LHC rts) + * Added: src/welcome_message.f90 + introduced "HOPPET" name + * Added: corresponding mods in convolution. + +2006-05-09 Gavin Salam + + * Added tests/determine_accuracies.f90 + * swtiched some errors in convolution.f90 (and elsewhere) over to + the "official" warnings_and_errors handling. + +2006-05-07 Gavin Salam + + * Implemented deletion of grid_def's + some more name changes + (notably, pdfset -> pdf in evolution.f90 + + * implemented direction=-1 for mass thresholds and tested that it + works properly, using the tests/birectional_mass_thresholds + program (and running it with various alphas values). + + * more name changes (extra "Delete") + introduced InitEvlnOperator(...) + + * switched warnings_and_errors over to a new version. + + * changed interfaces in evolution.f90 and pdf_tabulate.f90 so as + to make nloop an optional argument, with the default number of + loops being deduced from the running_coupling object; also + introduced NumberOfLoops(coupling) function for the + running_coupling, allowing other routines to find out what is + going on. + + * changed directory structure (for now), with a new directory + tests/, while the old testing directory has become testing-other + (devoted to testing things that are not directly related the + program development). + + * some name changes in evolution.f90 designed to make things more + uniform wrt rest of program. + +2006-05-05 Gavin Salam + + * moved some arguments around for the running_coupling type, and + introduced an optional quark_masses(4:6) argument for setting the + charm, bottom and top (pole) masses. + + * major name changes related to running coupling handling -- + hopefully it should all become somwhat more logical... + + +2006-05-04 Gavin Salam + + * moved holders.f90 -> dglap_holders.f90 (so its name now + coincides with module name). + + * various name changes in holders.f90 (and global name changes, + such that gd -> grid and sh -> dh). + +2006-05-02 Gavin SALAM + + * some more name changes in dglap_objects; removed limitation in + MTM convolution on absence of heavy flavour (necessary to allow + crossing of threshold when evolving downwards, where there is + almost bound to be some residual heavy-quark piece). + + * one internal name change in convolution.f90 to avoid subsequent + problems with SetToCommutator. + + * merged dglap_objects and dglap_objects hidden (which were + separated only for support of legacy f90 compilers, hopefully no + longer in existence). Added SetToZero, SetToConvolution, + SetToCommutator. + + * removed number of loops from the split_mat type (it wasn't being + used). + +2006-05-01 Gavin Salam + + * started work on giving consistent names to routines for + working with splitting functions in dglap_objects.f90 + + * Moved conv_objects.f90 to dglap_objects.f90, changed + PMat -> split_mat + CMat -> coeff_mat + MassThresholdMat -> mass_threshold_mat + + * Put some case-insensitivity into the convert.pl script. + + * Added version of CopyHumanPdfToEvln etc. where first argument + is nf (integer) rather than a pdf_rep -- that should makes its use + a bit more transparent to people. Also switched the rest of the + code to make use of the new call and removed all prep information + from sigma_holder. [Tested that answers are unchanged!] + + * further name changes throughout + + * added Delete function for sigma_holder + + * convolution.f90: fixed various potential memory leaks automatic + detection of need to allocate grid_conv objects. + + * pdf_representation.f90: representation changes now leave decoupled + heavy flavours unchanged, rather than setting them to zero. + +2006-04-30 Gavin Salam + + * various name changes to simplify life for the user (mainly + removal of prefixes which add little information and just make for + more things to remember) + + * added scripts/convert.pl which carries out most of the name + changes automatically (sometimes one or two resulting name clashes + then had to be fixed by hand). Hopefully this script can also be + used for conversion of existing example programs + + * documentation moving forwards. Section 3 on one-flavour problems + is now at the first draft stage. Should probably next move on to + section 4 for dealing with flavour problems. + +2006-04-28 Gavin Salam + + * switched sort.f90 to be my own version. + * removed unused interpolation routines from interpolation.f90 + +2006-04-07 Gavin Salam + + * Added the example_f90/small_fast_tab.f90 program to examine + timings and accuracies for a (by default) small tabulation. + + Default parameters give 10^{-4} accuracy at 3 ms/evolution over + the small region (Rojo's request: 9-e3 + + Version 1.0 + + * imported sources from the PDFevln package, with the addition of + some f77 hooks and the removal of all the main programs; also a + directory structure has been introduced so that the library source + in is src/ while the example and testing programs are in separate + directories. + + diff --git a/README b/README new file mode 100644 index 0000000..ade04f6 --- /dev/null +++ b/README @@ -0,0 +1,87 @@ +README for the pdf-conv directory +--------------------------------- + +This is a version of the PDFevln package that additionally provides a +f77 interface to allow a simple determination of convolutions of +splitting functions with a given pdf set. This is useful in various +contexts such as inclusion of factorization scale dependence in +a-posteriori inclusion of PDFs for jet calculations; or for matching +between fixed-order and resummed calculations. + +To see what routines are available, and which other parameters are +around, examine src/f77_pdftab.f90 + +Note that compilation requires a fortran 90 compiler -- those that +have been tested (to varying extents) include ifort, lf95, g95 and +gfortran, some of which (all but lf95) are available freely to varying +extents; for initialisation g95 is found to be quite a bit slower than +the other compilers. + +Complaints and questions should be addressed to +Gavin Salam + +On request the f77 interface may be extended to include easy access to +the evolution part of the package. + +#----------------------------------------------------------------- +# To compile library: +#------------------- +> cd src +# edit fortran 90 compiler in Makefile if need be +> make + +# then to compile example program +#-------------------------------- +> cd ../example_f77 +# edit Makefile so as to include the appropriate f90 and LHAPDF libraries +> make + +# then run it as follows and check output against what is below +> ./convolution_example + ************************************* + * LHAPDF Version 5.0 * + ************************************* + + >>>>>> PDF description: <<<<<< + CTEQ6.1 + Reference: + J. Pumplin, D.R. Stump, J. Huston, H.L. Lai + W.K. Tung, S. Kuhlmann, J. Owens + hep-ph/0303013 + This set has 41 member PDF + mem=0 --> central value (cteq61m) + mem=1-40 --> 20 sets of +ve/-ve error values + >>>>>> <<<<<< + + ----------------------------------------------------------- + This is the PDFevln package + + Written by Gavin P. Salam (2001-2006) + + It is made available under the GNU public license, + with the additional restriction that if you use it or any + derivative of it then you should cite: + M. Dasgupta and G.P. Salam, Eur.Phys.J.C24:213-236,2002. + + You are also encouraged to cite the original references, + for LO, NLO and NNLO splitting functions, the QCD + 1, 2 and 3 loop beta functions and the coupling and + PDF mass threshold matching functions. + ----------------------------------------------------------- + + x = 0.1, Q = 30. + iflv lhapdf ourpdf PLO_conv_ourpdf PNLO_conv_ourpdf + -6 0.0000000 0.0000000 0.0000000 0.0000000 + -5 0.0148786 0.0148821 0.0921542 0.1938882 + -4 0.0314312 0.0314340 0.0528865 0.0249562 + -3 0.0608825 0.0608848 -0.0095773 -0.2567813 + -2 0.0885760 0.0885775 -0.0763528 -0.5440898 + -1 0.1214880 0.1214896 -0.1300409 -0.8175595 + 0 0.9779542 0.9779997 -2.2731258 1.6135916 + 1 0.3832341 0.3832380 -0.3130459 -2.1597162 + 2 0.6185498 0.6185565 -0.2770019 -2.6512379 + 3 0.0608825 0.0608848 -0.0095773 -0.2567813 + 4 0.0314312 0.0314340 0.0528865 0.0249562 + 5 0.0148786 0.0148821 0.0921542 0.1938882 + 6 0.0000000 0.0000000 0.0000000 0.0000000 + diff --git a/doc/HOPPET-v1-doc.tex b/doc/HOPPET-v1-doc.tex new file mode 100644 index 0000000..f50dd11 --- /dev/null +++ b/doc/HOPPET-v1-doc.tex @@ -0,0 +1,1946 @@ +\documentclass[12pt]{article} +%% TO DO: +%% +%% Make sure hopper is replaced with final name... +% +% Possible names: +% HOAXE: High-Order Accelerated X-space Evolution +% +\usepackage{a4wide} +\usepackage{amsmath} +\usepackage{amssymb} +\usepackage{url} +\usepackage{xspace} + +\newcommand{\bq}{\boldsymbol{q}} +\newcommand{\GeV}{\;\mathrm{GeV}} +\newcommand{\as}{\alpha_s} +\newcommand{\comment}[1]{\textbf{[#1]}} +\newcommand{\eg}{e.g.\ } +\newcommand{\ie}{i.e.\ } +\newcommand{\MSbar}{\overline{\mathrm{MS}}} +\newcommand{\hoppet}{\textsc{hoppet}\xspace} +\newcommand{\ttt}[1]{\texttt{#1}} +\newcommand{\order}[1]{{\cal O}\left(#1\right)} + +%----------------------------------------- +\title{Higher Order Perturbative Parton Evolution Toolkit \\ + a.k.a.\ HOPPETv1 +} +\author{G.~P. Salam\\ + LPTHE, Univerities of Paris 6 \& 7 and CNRS, Paris 75005, France. +} +\date{} + + +%====================================================================== +\begin{document} + +\maketitle + +\abstract{This document describes a Fortran~95 package for carrying + out DGLAP evolution and other common manipulations of parton + distribution functions (PDFs). The PDFs are represented on a grid in + $x$-space so as to avoid limitations on the functional form of input + distributions. Good speed and accuracy are obtained through the + representation of splitting functions in terms of their convolution + with a set of piecewise polynomial basis functions, and Runge-Kutta + techniques are used for the evolution in $Q$. Unpolarised evolution + is provided to NNLO, including heavy-quark thresholds \comment{say + MSbar?}, and polarised evolution to NLO. The code is structured so + as to provide simple access to the objects representing splitting + function and PDFs, making it possible for a user to extend the + facilities already provided. + % + A `vanilla' interface is also available \comment{in progress}, + facilitating use of the evolution part of the code from f77, C and + C++. \smallskip + + \textbf{Note:} this document describes version~1 of the package. A + far more object-oriented version (v2) has undergone substantial + development, making use of the so-called TR15581 part of + Fortran~2003 (allocatable arrays as part of derived types). While + v2 (available on request) is more flexible and structured than v1, + it is also considerably larger, not quite as fast, less tolerant of + all but the most recent compilers, and currently lacking the + tabulation feature. For this reason it was deemed worthwhile to + provide a documented version of v1.} + +\newpage + +\tableofcontents + +%====================================================================== +%====================================================================== +\section{Introduction} +\label{sec:intro} + +There has been considerable discussion over the past years~\cite{}, of +numerical solutions of the DGLAP equation~\cite{DGLAP} for the +evolution QCD parton distributions. + + +The Dokshitzer-Gribov-Lipatov-Altarelli-Parisi (DGLAP) equation +\cite{DGLAP} is a renormalisation group equation for the quantity +$q_i(x,Q^2)$, the density of partons of type (or flavour) $i$ carrying +a fraction $x$ of the longitudinal momentum of a hadron, when resolved +at a scale $Q$. It is one of the fundamental equations of perturbative +quantum chromodynamics (QCD), being central to all theoretical +predictions for hadron-hadron and lepton-hadron colliders. + +Technically, it is a matrix integro-differential equation, +\begin{equation} + \label{eq:dglap} + \frac{\partial q_i(x,Q^2)}{\partial \ln Q^2} = \int \frac{dz}{z} + P_{ij}(z,Q^2) q_j(x,Q^2)\,, +\end{equation} +whose kernel elements $P_{ij}(z,Q^2)$ are known as splitting +functions, since they describe the splitting of a parton of kind $j$ +into a parton of kind $i$ carrying a fraction $z$ of the longitudinal +momentum of $j$. The parton densities themselves $q_i(x,Q^2)$ are +essentially non-perturbative, since they depend on physics at hadronic +mass scales $\lesssim 1 \GeV$, where the QCD coupling is large. On the +other hand the splitting functions are given by a perturbative +expansion in the QCD coupling $\as(Q^2)$. Thus given partial +experimental information on the parton densities\footnote{Actually it + is not the parton densities, but rather structure functions, which + can be derived from them perturbatively, that are measured + experimentally.} % +--- for example over a limited range of $Q$, or for only a subset of +parton flavours --- the DGLAP equations can be used to reconstruct the +parton densities over the full range of $Q$ and for all flavours. + +The pivotal role played by the DGLAP equation has motivated a +considerable body of literature discussing its numerical solution +\cite{AllDGLAP}. There exist two main classes of approach: those that +solve the equation directly in $x$-space and those that solve it for +Mellin transforms $q_{iN}(Q^2) = \int dx x^N q_i(x,Q^2)$, of the +parton densities and susbequently invert the transform back to +$x$-space. The latter are of interest because the Mellin transform +converts the convolution of eq.(\ref{eq:dglap}) into a multiplication, +resulting in a continuum of independent matrix differential (rather +than integro-differential) equations, one for each value of $N$, +making the evolution very efficient numerically. The drawback of the +method stems however from the need to know the Mellin transforms of +both the splitting functions and the initial conditions and to a +lesser extent subtleties associated with the inverse Mellin transform. + +The $x$-space method is in contrast more flexible, since the inputs +are only required in $x$-space; however it is generally considered to +much less efficient numerically, because of the need to carry out the +convolution in eq.(\ref{eq:dglap}). + +To understand the question of efficiencies one should analyse the +number of operations needed to carry out the... + + + +Each has advantages +and drawbacks: the $x$-space method provides information over a range +of $x$ values. + +%---------------------------------------------------------------------- +\section{Tricks} +\label{tricks} + +%...................................................................... +\subsection{Higher order matrix representation} +\label{sec:highord} + +This is higher-order in numerical sense, not perturbative QCD sense. +We have a lower triangular matrix. + +Grid points $y_\alpha$, indicated by index $\alpha$; uniform grid +spacing: $y_\alpha = \alpha \delta y$. +\begin{equation} + q(y,t) = w_\alpha(y) q_\alpha(t)\,. +\end{equation} +Weights serve to interpolate: $q_\alpha = q(y_\alpha)$, +$w_\alpha(y_\beta) = \delta_{\alpha\beta}$. +\begin{equation} + (P \otimes q)_\alpha = +\end{equation} + + +%...................................................................... +\subsection{Evolution operators} +\label{sec:evop} +Have +\begin{equation} + \partial_t q_{\alpha}(t) = \sum_{\beta} P_{\alpha\beta}(t) q_\beta(t) +\end{equation} +Introduce $M_{\alpha\beta}(t_0) = \delta_{\alpha\beta}$. Solve +\begin{equation} + \partial_t M_{\alpha\beta}(t) = \sum_{\gamma} P_{\alpha\gamma}(t) + M_{\gamma\beta}(t) +\end{equation} +Then +\begin{equation} + q_{\alpha}(t) = \sum_{\beta} M_{\alpha\beta}(t) q_\beta(t_0) +\end{equation} +If once can rewrite $P$ as $P_{\alpha\beta} = \cal P_{\alpha-\beta}$, +then similarly one can rewrite $M_{\alpha\beta} = \cal +M_{\alpha-\beta}$, and it is as simple to determine +$M_{\alpha\beta}(t)$ as it is to determine the evolution of a single +vector $q_\alpha$, i.e.\ one just evolves a single column, $\beta = +0$, of $M_{\alpha\beta}(t)$. + + +%---------------------------------------------------------------------- +\section{Single-flavour grids and convolutions} + +The software package is written in f90. This has considerable +advantages compared to f77, as will be seen in the discussion of the +program, though it does lack a number of fully object-oriented +features and this sometimes restricts the scope for expressiveness. +Fortran~90 perhaps not being the best known language in the +high-energy community, occasionally some indications will be give to +help the reader with less-known language constructs, with further +information in appendix~\ref{sec:f95appendix}. + +All routines described in this section need access to the +\texttt{convolution} module, which can either be obtained directly by +adding a +\begin{verbatim} + use convolution +\end{verbatim} +statement at the beginning of the relevant subprogram (before +any \ttt{implicit none} or similar declarations). Alternatively, as +with the rest of the routines described in this documentation, it can +be accessed indirectly through the \ttt{hoppet\_v1} module +\begin{verbatim} + use hoppet_v1 +\end{verbatim} +Unless you are delving into the innards of the \hoppet, the latter is +more convenient since it provides access to everything you are likely +to need. + +%...................................................................... +\subsection{Grid Definitions (\texttt{grid\_def})} +\label{sec:grid} + +The grid is the central element of the PDF evolution. Information +concerning the grid is stored in a derived type \texttt{grid\_def}, +which can be initialised as follows: +\begin{verbatim} + type(grid_def) :: grid + call InitGridDef(grid,dy=0.1_dp,ymax=10.0_dp,order=3) +\end{verbatim} +This initialises a grid between $x=1$ and down to $x = +e^{-\texttt{ymax}}$, with grid spacing in $y = \ln 1/x$ of +\texttt{dy}. The grid will use 3rd order interpolation. + +One notes the use of keyword arguments --- the keywords are not +mandatory in this case, but have been included to improve the +legibility. + +Having defined a grid, the user need not worry about the details of +the grid representation. + +In line with the convention set out in the Fortran~90 edition of +Numerical Recipes \cite{NRf90} we shall use \texttt{\_dp} to indicate +that numbers are in double precision, and \ttt{real(dp)} to declare +double precision variables. The integer parameter \ttt{dp} is defined +in the \texttt{module types} (and available indirectly through +\ttt{module hoppet\_v1}). + +As discussed above, it is often useful to have multiple grids, with +coarse coverage at small $x$ and fine coverage at high $x$. To support +this we can first defined an array of sub-grids, and then use it +initialise a combined grid +\begin{verbatim} + type(grid_def) :: grid, subgrids(3) + + ! define the various sub-grids + call InitGridDef(subgrids(1),dy=0.30_dp, ymax=10.0_dp, order=3) + call InitGridDef(subgrids(2),dy=0.10_dp, ymax= 2.0_dp, order=3) + call InitGridDef(subgrids(3),dy=0.03333_dp, ymax= 0.6_dp, order=3) + + ! put them together into a single combined grid + call InitGridDef(grid, subgrids, locked=.true.) +\end{verbatim} +When combining them the \ttt{locked=.true.} option has been specified, +which ensures that after any convolution, information from the finer +grids is propagated into the coarser ones. This places some +requirements on the grid spacings, notably that a coarse grid have a +spacing that is a multiple of that of the next finest grid. If the +requirements are not satisfied by the \ttt{subgrids} that have been +provided, then new similar, but more suitable subgrids are +automatically generated. + +Note that the two kinds of invocation of \ttt{InitGridDef} actually +correspond to different subroutines. The fortran~90 compiler +automatically selects the correct one on the basis of the types of +arguments passed. + +Though only grids that are uniform in $y$ have been implemented, +nearly all of the description that follows and all code outside the +\texttt{convolution} module are independent of this detail (the only +exception being certain statements about timings). Therefore were +there to be a strong motivation for an alternative, non-uniform grid, +it would suffice to modify the \texttt{convolution} module, while the +rest of the library (and its interfaces) would remain unchanged. + +%...................................................................... +\subsection{$x$-space functions} +\label{sec:xspc} + +Here we encounter our first difficulties, and departure from an +object-oriented `ideal'. Normal $x$-space functions (such as PDFs) are +held in double precision arrays, which are to be allocated as follows +\begin{verbatim} + real(dp), pointer :: gluon(:) + call AllocGridQuant(grid,gluon) +\end{verbatim} +Note that for this to work, \texttt{gluon(:)} should be a +\texttt{pointer} not just have the \texttt{allocatable} attribute. To +deallocate a grid quantity, one may safely use the f90 +\texttt{deallocate} command. + +Since \texttt{gluon(:)} is just an array, it carries no information +about the \texttt{grid}. Therefore to set and access its value, one +must always provide the information about the \texttt{grid}. This is +not entirely satisfactory, and is one of the drawbacks of the use of +f90, as will be explained later on. + +There are a number of ways of setting a grid quantity. Suppose we have +a subroutine +\begin{verbatim} + subroutine example_gluon(y,g) + use types !! defines "dp" (double precision) kind + implicit none + real(dp), intent(in) :: y + real(dp), intent(out) :: g + real(dp) :: x + + x = exp(-y) + g = 1.7_dp * x**(-0.1_dp) * (1-x)**5 + end subroutine example_gluon +\end{verbatim} +Then we can call +\begin{verbatim} + call InitGridQuantSub(grid,gluon,example_gluon) +\end{verbatim} +to initialise \texttt{gluon} with a representation of the return value +from the subroutine \texttt{example\_gluon}. An alternative way is to +make use of functions \texttt{xValues} or \texttt{yValues} that +respectively return the $x$ or $y$ values of all points on the grid: +\begin{verbatim} + real(dp), poitner :: gluon,xvals + call AllocGridQuant(grid,gluon) + call AllocGridQuant(grid,xvals) + xvals = xValues(grid) + gluon = 1.7_dp * xvals**(-0.1_dp) * (1-xvals)**5 + deallocate(xvals) +\end{verbatim} +Though more laborious insofar as one has to worry about some extra +allocation and deallocation, it has the advantage that one no longer +has to write a separate subroutine. + + +To then access the gluon at a given value of $y = \ln 1/x$, one +proceeds as follows +\begin{verbatim} + real(dp) :: y, gluon_at_y + ... + y = 5.0_dp + gluon_at_y = EvalGridQuant(grid,gluon,y) +\end{verbatim} +We have to supply the \texttt{grid} argument to \ttt{EvalGridQuant} +because the \ttt{gluon} array itself carries no information about the +grid (other than its size). + +A less efficient, but perhaps more `object-oriented' way of accessing +the gluon is via the notation \comment{make it more efficient and + safe: get \texttt{y.with.grid} to return a structure directly + containing weights? Should see how inefficient it really is...} +\begin{verbatim} + gluon_at_y = gluon .aty. (y.with.grid) +\end{verbatim} +There also exists an \ttt{.atx.} operator for evaluating the PDF at a +given $x$ value. Many of these procedures and operators are +overloaded so as to work with higher-dimensional arrays of grid +quantities, for example a \texttt{pdf(:,:)}. The first index will +always correspond to the representation on the grid, while the second +index would here indicate the flavour. + +Note that arithmetic operators all have higher precedence than +library-defined operators such as \texttt{.aty.}; accordingly some +ways of writing things are more efficient than others: +\begin{verbatim} + gluon_at_y = 2 * gluon .aty. (y.with.grid) ! very inefficient + gluon_at_y = 2 * (gluon .aty. (y.with.grid)) ! fairly efficient + gluon_at_y = 2 * EvalGridQuant(grid,gluon,y) ! most efficient +\end{verbatim} +In the first case the whole of the array \texttt{gluon} is multiplied +by 2, and then the result is evaluated at $y$, whereas in the second +case only the result of the gluon at $y$ is multiplied by 2. + +%...................................................................... +\subsection{Grid Convolution operators} +\label{sec:conv} + +While it is relatively straightforward internally to represent a +grid-quantity (e.g.\ parton distribution) as an array, for convolution +operators, it is generally useful to have certain extra +information. Accordingly a derived type has been defined to hold a +convolution operator, and routines are provided for allocation and +initialisation of splitting functions. +\begin{verbatim} + type(grid_conv) :: Pgg + call AllocGridConv(grid,Pgg) + call InitGridConv(Pgg, Pgg_func) +\end{verbatim} +where the $P_{gg}$ splitting function is provided in the form of the +function \texttt{Pgg\_func} +\begin{verbatim} + ! returns various components of exp(-y) P_gg (exp(-y)) + real(dp) function Pgg_func(y) + use types + use convolution_communicator ! provides cc_piece, and cc_REAL,... + use qcd ! provides CA, TR, nf, ... + implicit none + real(dp), intent(in) :: y + real(dp) :: x + + x = exp(-y); Pgg_func = zero + if (cc_piece == cc_DELTA) then + Pgg_func = (11*CA - 4*nf*TR)/6.0_dp + else + if (cc_piece == cc_REAL .or. cc_piece == cc_REALVIRT) & + & Pgg_func = 2*CA*(x/(one-x) + (one-x)/x + x*(1-x)) + if (cc_piece == cc_VIRT .or. cc_piece == cc_REALVIRT) & + & Pgg_func = Pgg_func - 2*CA*one/(one-x) + Pgg_func = Pgg_func * x ! remember to return x * Pgg + end if + end function Pgg_func +\end{verbatim} +To address the issue that convolution operators can involve +plus-distributions and delta functions, the module +\texttt{convolution\_communicator} contains a variable +\texttt{cc\_piece} which indicates which part of the splitting +function is to be returned --- the real, virtual, real + virtual, or +$\delta$-function pieces. Note that in all cases $P_{gg}(x)$ is to be +returned multiplied by $x$. + +The initialisation of a \texttt{grid\_conv} object uses an adaptive +Gaussian integrator (a variant of CERNLIB's \texttt{dgauss}) to +calculate the convolution of the splitting function with trial weight +functions. The default accuracy for these integrations is $10^{-7}$. +It can be modified to value \texttt{eps} with the following subroutine +call +\begin{verbatim} + call SetDefaultConvolutionEps(eps) +\end{verbatim} +Note that this is just one of the parameters affecting the final +accuracy of convolutions. In practice (unless going to extremely high +accuracies) the grid spacing and interpolation scheme are more +critical. + +Having allocated and initialised a \texttt{Pgg} splitting function, we +can go on to use it. For example +\begin{verbatim} + real(dp), pointer :: Pgg_x_gluon(:) + ... + call AllocGridQuant(grid,Pgg_x_gluon) + Pgg_x_gluon = Pgg .conv. gluon +\end{verbatim} +Since the return value of \texttt{Pgg .conv.\ gluon} is just an f90 +array, one can also write more complex expressions. Supposing we had +defined also a \texttt{Pgq} splitting function and a singlet +\texttt{quark} distribution, as well as $\texttt{as2pi} = \as/2\pi$, +then to first order in $\as$ we could write the gluon evolution +through a step \texttt{dt} in $\ln Q^2$ as +\begin{verbatim} + gluon = gluon + (as2pi*dt) * ((Pgg .conv. gluon) + (Pgq .conv. quark)) +\end{verbatim} +Note that like \texttt{.aty.}, \texttt{.conv.} has a low precedence, +so the use of brackets is important to ensure that the above +expressions are sensible. Alternatively, the issues of precedence can +be addressed by using \texttt{*} (also defined as convolution when it +appears between a splitting function and a PDF) instead of +\texttt{.conv.}: +\begin{verbatim} + gluon = gluon + (as2pi*dt) * (Pgg*gluon + Pgq*quark) +\end{verbatim} + + +%...................................................................... +\subsubsection{Other operations on \texttt{grid\_conv} objects} +\label{sec:other_grid_conv_ops} +% +It is marginally less transparent to manipulate \texttt{grid\_conv} types +than PDF distributions, but still fairly simple: +\begin{verbatim} + call AllocGridConv(grid,Pab) ! Pab memory allocated + call InitGridConv(grid,Pab) ! Pab = 0 (opt.alloc) + call InitGridConv(Pab,Pcd[,factor]) ! Pab = Pcd [*factor] (opt.alloc) + call InitGridConv(grid,Pab,function) ! Pab = function (opt.alloc) + + call SetToZero(Pab) ! Pab = 0 + call Multiply (Pab,factor) ! Pab = Pab * factor + call AddWithCoeff(Pab,Pcd[,coeff]) ! Pab = Pab + Pcd [*coeff] + call AddWithCoeff(Pab,function) ! Pab = Pab + function + + call SetToConvolution(Pab,Pac,Pcb) ! Pab = Pac.conv.Pcb (opt.alloc) + call SetToConvolution(P(:,:),Pa(:,:),Pb(:,:)) ! (opt.alloc) + ! P(:,:) = matmul(Pa(:,:),Pb(:,:)) + call SetToCommutator(P(:,:),Pa(:,:),Pb(:,:)) ! (opt.alloc) + ! P(:,:) = matmul(Pa(:,:),Pb(:,:)) + ! -matmul(Pb(:,:),Pa(:,:)) + + call Delete(Pab) ! Pab memory freed +\end{verbatim} +Routines labelled ``\texttt{(opt.alloc.)}'' allocate the memory for +the \texttt{grid\_conv} object if the memory has not already been +allocated. (If it has already been allocated it is assumed to +correspond to the same grid as any other \texttt{grid\_conv} objects +in the same subroutine call). Some calls require that one specify the +grid definition being used (\texttt{grid}), because otherwise there is +no way for the subroutine to deduce which grid is being used. + +When creating a \texttt{grid\_conv} object for temporary use, it is +important to remember to \texttt{Delete} it afterwards, so as to avoid +memory leaks. + +Nearly all the routines are partially overloaded so as to be able to +deal with one and two-dimensional arrays of \texttt{grid\_conv} +objects as well. The exceptions are those that initialise the +\texttt{grid\_conv} object from a function (arrays of functions do not +exist), as well as the convolution routines (for which the extension +to arrays might be considered non-obvious) and the commutation routine +which only has sense for matrices of \texttt{grid\_conv} objects. + +%...................................................................... +\subsubsection{Derived \texttt{grid\_conv} objects} +\label{sec:derived_grid_conv} + +Sometimes it can be cumbersome to manipulate the \texttt{grid\_conv} +objects directly, for example when trying to create a +\texttt{grid\_conv} that represents not a fixed order splitting +function, but the resummed evolution from one scale to another. For +such situations the following approach can be used +\begin{verbatim} + real(dp), pointer :: probes(:,:) + type(grid_conv) :: Pqg, Pgq, Presult + integer :: i + + call GetDerivedProbes(grid,probes) ! get the probes + do i = 1, size(probes,dim=2) ! carry out operations on each of the probes + probes(:,i) = Pqg*(Pgq*probes(:,i)) - Pgq*(Pqg*probes(:,i)) + end do + call AllocGridConv(grid,Presult) + call SetDerivedConv(Presult,probes) ! Presult = [Pqg,Pgq] +\end{verbatim} +Here \texttt{GetDerivedProbes} allocates and sets up an array of probe +parton distributions. Since a single-flavour parton distribution is a +one-dimensional array of \texttt{real(dp)}, the array of probes is a +two-dimensional array of \texttt{real(dp)}, the second dimension +corresponding to the index of the probe. One then carries out whatever +operations one wishes on each of the probes. Finally with the call to +\texttt{SetDerivedConv}, one can reconstruct a \texttt{grid\_conv} +object that corresponds to the set of operations just carried out + +Some comments about memory allocation: the probes are automatically +allocated and deallocated; in contrast the call to +\texttt{SetDerivedConv(Presult,probes)} knows nothing about the grid, +so \texttt{Presult} must have been explicitly allocated for a specific +grid beforehand. + +A note of caution: when one's grid is made of nested subgrids with the +locking option set to \texttt{.true.}, after a convolution of a +\texttt{grid\_def} object with a parton distribution, the coarser +grids for the parton distribution are supplemented with more accurate +information from the finer grids. When carrying out multiple +convolutions, this happens after each convolution. There is no way to +emulate this with a single \texttt{grid\_def} object, and the locking +would actually confuse the reconstruction of resulting +\texttt{grid\_def} object. So when the user requests the probes, +locking is temporarily turned off globally and then reestablished +after the derived \texttt{grid\_object} has been contructed. Among +other things this means that acting with a derived +\texttt{grid\_object} will not be fully equivalent to carrying out the +individual operations separately. In particular the accuracy may be +slightly lower (whatever is lost due to the absence of intermediate +locking). + + + + + + +%====================================================================== +%====================================================================== +\section{Multi-flavour grids and convolutions} +\label{sec:dglapstructs} + +The above discussion holds for any kind of problem involving +convolutions, even if the examples were given in the context of DGLAP +evolution. In this section we shall examine the tools made available +specifically to address the DGLAP evolution problem. + + +%---------------------------------------------------------------------- +\subsection{Full-flavour PDFs and flavour representations} +\label{sec:pdf-objects} + +The routines described here are available from the \ttt{pdf\_general} +and \ttt{pdf\_representation} modules, or via the \ttt{hoppet\_v1} +general module. + +Full flavour PDFs are just like single flavour PDFs except that they +have an extra dimension. They are represented by arrays, and if you +want \hoppet to deal with allocation for you, they should be pointer +arrays. One can allocate a single PDF (two dimensional +\texttt{real(dp)} array) or an array of PDFs (three-dimensional +\texttt{real(dp)} array) +\begin{verbatim} + real(dp), pointer :: PDF(:,:), PDFarray(:,:,:) + call AllocPDF(grid,PDF) ! allocates PDF(0:,-6:7) + call AllocPDF(grid,PDFarray,0,10) ! allocates PDFarray(0:,-6:7,0:10) +\end{verbatim} +The first dimension corresponds to the grid in $y$; the second +dimension corresponds to the flavour index. Its lower bound is $-6$, +as one would expect. What takes a bit more getting used to is that its +upper bound is \textbf{7}. The reason is as follows: the flavour +information can be represented in different ways, for example each +flavour separately, or alternatively as singlet and non-singlet +combinations. In practice both are used inside the program and it is +useful for a PDF distribution to have information about the +representation it is in --- it is this that is stored in +\texttt{PDF(:,7)}. + +%...................................................................... +\subsubsection{Human representation.} +\label{sec:human-rep} +When a PDF is allocated it is automatically labelled as being in the +\ttt{human} representation, in which $\bar t={-6}, \bar b={-5}, \bar +c={-4}, \bar s={-3}, \bar u={-2}, \bar d={-1}, g={0}, d={1}, u={2}, +s={3}, c={4}, b={5}, t={6} $. Constants with names like +\ttt{iflv\_bbar}, \ttt{iflv\_g}, \ttt{iflv\_b}, are defined in +\ttt{module pdf\_representation}, to facilitate symbolic access to the +different flavours. + +If you are creating a PDF as an automatic array (one whose bounds are +decided not by the allocation routine, but on the fly), for example in +a function that returns a PDF, then you should label it yourself as +being in the \ttt{human} representation, either with the the +\ttt{LabelPdfAsHuman(pdf)} subroutine call, or by setting +\ttt{pdf(:,7)} to zero: +\begin{verbatim} +module pdf_initial_condition + use hoppet_v1; implicit none +contains + function unpolarized_dummy_pdf(xvals) result(pdf) + real(dp), intent(in) :: xvals(:) + real(dp) :: pdf(size(xvals),-6:7) + + ! clean method for labelling as PDF as being in the human representation + call LabelPdfAsHuman(pdf) + ! by setting everything to zero (notably pdf(:,7)) representation + ! is automatically set to be human + pdf(:,:) = 0 + + ! iflv_g is pre-defined integer parameter (=0) for symbolic ref. to gluon + pdf(:,iflv_g) = 1.7_dp * xvals**(-0.1_dp) * (1-xvals)**5 + [... set other flavours here ...] + end function unpolarized_dummy_pdf +end module pdf_initial_condition +\end{verbatim} +The function has been placed in a module so as to provide an easy way +for a calling routine to have access to its interface (this is needed +for the dimension of \ttt{xvals} to be correctly passed). Writing a +function such as that above is probably the easiest way of +initialising a pdf: +\begin{verbatim} + use hoppet_v1; use pdf_initial_condition; implicit none + type(grid_def) :: grid + real(dp), pointer :: pdf(:,:) + [...] + call AllocPDF(grid,pdf) + pdf = unpolarized_dummy_pdf(xValues(grid)) +\end{verbatim} +There exist a number of other options, which can be found by browsing +through \ttt{src/pdf\_general.f90}. Of these a sometimes handy one is +\begin{verbatim} + call AllocPDF(grid,pdf) + call InitPDF_LHAPDF(grid, pdf, LHAsub, Q) +\end{verbatim} +where \texttt{LHAsub} is the name of a subroutine +%(to be declared +%\ttt{external} if an explicit interface is not available?) +with the same interface as LHAPDF's \ttt{evolvePDF} \cite{LHAPDF}: +\begin{verbatim} + subroutine LHAsub(x,Q,res) + use types; implicit none + real(dp), intent(in) :: x,Q + real(dp), intent(out) :: res(*) ! on output contains flavours -6:6 at x,Q + [...] + end subroutine LHAsub +\end{verbatim} + + +Having initialised a PDF, to then extract it at a given $y$ value, one +can either examine a particular flavour using the methods described in +section~\ref{sec:xspc} +\begin{verbatim} + real(dp) :: y, gluon_at_y + gluon_at_y = pdf(:,iflv_g) .aty. (y.with.grid) + ! OR + gluon_at_y = 2 * EvalGridQuant(grid,pdf(:,iflv_g),y) +\end{verbatim} +or one can extract all flavours simultaneously +\begin{verbatim} + real(dp) :: pdf_at_y(-6:6) + pdf_at_y = pdf(:,-6:6) .aty. (y.with.grid) + ! OR + pdf_at_y = 2 * EvalGridQuant(grid,pdf(:,-6:6),y) +\end{verbatim} +with the latter being more efficient if one needs to extract all +flavours simultaneously. Note that here we have explicitly specified +the flavours, here \ttt{-6:6}, that we want.\footnote{If instead we had + said \ttt{pdf(:,:)} the result would have corresponded to a slice of + flavours \ttt{-6:7}, \ie including an interpolation of the + representation labelling information, which would be meaningless.} + + +%...................................................................... +\subsubsection{Evolution representation.} +\label{sec:evln-rep} +% +For the purpose of carrying out convolutions the \ttt{human} +representation is not very advantageous because the splitting matrix +in flavour space is quite complicated. Accordingly \hoppet uses a +different representation of the flavour internally when carrying out +convolution of splitting matrices with PDFs. For most purposes the +user need not be aware of this. The two exceptions are when a user +plans to create derived splitting matrices (being careless about the +flavour representation will lead to mistakes) or wishes to carry out +repeated convolutions for a fixed $n_f$ value (appropriate manual +changes of the flavour representation can speed things up). + + +The splitting matrix can be simplied considerably (made diagonal +except for a $2\times2$ singlet block) by switching to a different +flavour representation for \ttt{pdf(:,i)}, as explained in detail in +\cite{vanNeerven:1999ca,vanNeerven:2000uj} +\begin{equation} + \label{eq:diag_split} + \begin{array}{r | l| l } + i & \mbox{name} & q_i \\ \hline + -6\ldots-(n_f+1) & q_i & q_i\\ + -n_f\ldots -2 & q_{\mathrm{NS},i}^{-} & (q_i - {\bar q}_i) - (q_1 - {\bar q}_1)\\ + -1 & q_{\mathrm{NS}}^{V} & \sum_{j=1}^{n_f} (q_j - {\bar q}_j)\\ + 0 & g & \textrm{gluon} \\ + 1 & \Sigma & \sum_{j=1}^{n_f} (q_j + {\bar q}_j)\\ + 2\ldots n_f & q_{\mathrm{NS},i}^{+} & (q_i + {\bar q}_i) - (q_1 + {\bar q}_1)\\ + (n_f+1)\ldots6 & q_i & q_i + \end{array} +\end{equation} +When carrying out a convolution, the only non-diagonal part is the +block containing indices $0,1$. This representation is referred to as +the \ttt{evln} representation. Whereas the \ttt{human} representation +is $n_f$-independent the \ttt{evln} depends on $n_f$ through the +$\Sigma$ and $q_{\mathrm{NS}}^{V}$ entries and the fact that flavours +beyond $n_f$ are left in the human representation (since they are +inactive for evolution with $n_f$ flavours). + +To take a PDF in the \ttt{human} representation and make a copy in an +\ttt{evln} representation, one uses the \ttt{CopyHumanPdfToEvln} routine +\begin{verbatim} + real(dp), pointer :: pdf_human(:,:), pdf_evln(:,:) + integer :: nf_lcl + + [... setting up pdf_human, nf_lcl, etc. ...] + call AllocPDF(grid,pdf_evln) ! or it might be an automatic array + call CopyHumanPdfToEvln(nf_lcl, pdf_human, pdf_evln) +\end{verbatim} +where one specifies the $n_f$ value for the \ttt{evln} representation. +One can go in the opposite direction with +\begin{verbatim} + call CopyEvlnPdfToHuman(nf_lcl, pdf_evln, pdf_human) +\end{verbatim} + + +%---------------------------------------------------------------------- +\subsection{Splitting \comment{+coeff.fn} function matrices} +\label{sec:splitt-funct-matr} + +Splitting function matrices and their actions on PDFs are defined in +\ttt{module dglap\_objects} (accessible as usual from \ttt{module + hoppet\_v1}). They have type \ttt{split\_mat}. Below we shall discuss +routines for creating specific predefined DGLAP splitting matrices, +but for now we consider a general splitting matrix. + +Allocation, +\begin{verbatim} + type(split_mat) :: P + integer :: nf_lcl + call AllocSplitMat(grid, P, nf_lcl) +\end{verbatim} +is similar to that for \ttt{dglap_objects}. The crucial difference is +that one must supply a value for $n_f$, so that when the splitting +matrix acts on a PDF it knows which flavours are decoupled. From the +point of view of subsequent initialization a \ttt{split\_mat} object +just consists of a set of splitting functions, which act on the +components given in eq.(\ref{eq:diag_split}). If need be, they can be +initialized by hand, for example +\begin{verbatim} + call InitGridConv(grid,P%qq , P_function_qq ) + call InitGridConv(grid,P%qg , P_function_qg ) + call InitGridConv(grid,P%gq , P_function_gq ) + call InitGridConv(grid,P%gg , P_function_gg ) + call InitGridConv(grid,P%NS_plus , P_function_NS_plus ) + call InitGridConv(grid,P%NS_minus, P_function_NS_minus) + call InitGridConv(grid,P%NS_V , P_function_NS_V ) +\end{verbatim} +We can then write +\begin{verbatim} + real(dp), pointer :: q(:,:), delta_q(:,:) + [... allocations, etc. ...] + delta_q = P .conv. q + ! OR + delta_q = P * q +\end{verbatim} +and $\ttt{delta\_q}$ will have the following components +\begin{align} + \label{eq:Pmat_on_q} + \left(\!\! + \begin{array}{c} + \delta\Sigma\\ + \delta g + \end{array} + \!\!\right) + \;&= \; + \left( + \begin{array}{cc} + \ttt{P\%qq} & \ttt{P\%qg}\\ + \ttt{P\%gq} & \ttt{P\%gg} + \end{array} + \right) + \otimes + \left(\!\! + \begin{array}{c} + \Sigma\\ + g + \end{array} + \!\!\right) + \nonumber\\[3pt] +% + \delta q^+_{\mathrm{NS},i} \;&=\; \ttt{P\%NS\_plus} \otimes + q^+_{\mathrm{NS},i}\\[3pt] +% + \delta q^-_{\mathrm{NS},i} \;&=\; \ttt{P\%NS\_minus} \otimes + q^-_{\mathrm{NS},i}\nonumber \\[3pt] +% + \delta q^V_{\mathrm{NS}} \;&=\; \ttt{P\%NS\_V} \otimes + q^V_{\mathrm{NS}} \nonumber +\end{align} +We have written the result in terms of components in the \ttt{evln} +representation (and this is the representation use for the actual +convolutions). When a convolution with a PDF in \ttt{human} +representation is carried out, the program automatically copies the +PDF to the \ttt{evln} representation, carries out the convolution and +converts the result back to the \ttt{human} representation. +% +The cost of changing a representation is $\order{N}$, whereas the +convolution is $\order{N^2}$, so in principle the former is +negligible. In practice, especially when aiming for high speed at low +$N$, the change of representation can imply a significant cost. In +such cases, if multiple convolutions are to be carried out, it may be +advantageous to manually change into the appropriate \ttt{evln} +representation, carry out all the convolutions and then change back to +the \ttt{human} manually representation at the end. +% +\comment{Caveat: currently the internal information in \ttt{q(:,7)} + does not distinguish between \ttt{evln} representations for + different $n_f$ values; so if \ttt{q} is in the \ttt{evln} + representation for the wrong $n_f$ value you will get a wrong + answer. This is bad and should be fixed!} + +As for \ttt{grid\_conv} objects, a variety of routines have been +implemented to help manipulate splitting matrices: +\begin{verbatim} + type(split_mat) :: PA, PB, PC + real(dp) :: factor + + -- InitSplitMat(grid, PA) ??? + call InitSplitMat(PA,PB[,factor]) ! PA = PB [*factor] (opt.alloc) + + call SetToZero(PA) ! PA = 0 + call Multiply(PA,factor) ! PA = PA * factor TEST IT + call AddWithCoeff(PA,PB[,factor]) ! PA = PA + PB [*factor] + + call SetToConvolution(PA,PB,PC) ! PA = PB*PC (opt.alloc) TEST IT + call SetToCommutator(PA,PB,PC) ! PA = PB*PC-PC*PB (opt.alloc) TEST IT + + call Delete(split_mat) ! PA's memory freed +\end{verbatim} + + +%...................................................................... +\subsubsection{Derived splitting matrices} +\label{sec:derived-split-matrices} + +As with \ttt{grid\_conv} objects, \hoppet provides means to construct +a \ttt{split\_mat} object that corresponds to an arbitrary series of +\ttt{split\_mat} operations, as long as they all involve the same +value of $n_f$. One proceeds in a very similar way, +\begin{verbatim} + real(dp), pointer :: probes(:,:,:) + type(split\_mat) :: PA, PB, Pcomm + integer :: i + + [...] + call GetDerivedSplitMatProbes(grid,probes) ! get the probes + do i = 1, size(probes,dim=3) ! carry out operations on each of the probes + probes(:,i) = PA*(PB*probes(:,:,i)) - PB*(PA*probes(:,:,i)) + end do + call AllocSplitMat(grid,Pcomm,nf_lcl) ! provide nf info in initialisation + call SetDerivedConv(Pcomm,probes) ! Presult = [Pqg,Pgq] +\end{verbatim} +As in section~\ref{sec:derived_grid_conv}, we first need to set up +some `probe' PDFs (note the extra dimension compared to earlier, since +we also have flavour information; the probe index always corresponds +to the last dimension); then we act on those probes; finally we +allocate the splitting matrix, and set its contents based on the +probes, which are then automatically deallocated. + + + +%---------------------------------------------------------------------- +\subsection{The DGLAP convolution components} +\label{sec:dglap_holder} + +%...................................................................... +\subsubsection{QCD constants} +\label{sec:qcd} + +The splitting functions that we set up will depend on various QCD +constants ($n_f$, colour factors), so it is useful to here to +summarize how they are dealt with within the program. + +The treatment of the QCD constants is \emph{not} object oriented. +There is a module (\ttt{qcd}) that provides access to commonly used +constants in QCD: +\begin{verbatim} + real(dp) :: ca, cf, tr, nf + integer :: nf_int + + real(dp) :: beta0, beta1, beta2 + [ ... ] +\end{verbatim} +Note that \ttt{nf} is in double precision\footnote{The author has + forgotten why, but suspects there might some good reason and is + therefore nervous of changing it!} --- if you want the integer value +of $n_f$, use \ttt{nf\_int}. + +To set the value of $n_f$, call +\begin{verbatim} + integer :: nf_lcl + call qcd_SetNf(nf_lcl) +\end{verbatim} +where we've used the variable \ttt{nf\_lcl} to avoid conflicting with +the \ttt{nf} variable provided by the \ttt{qcd} module. Whatever you +do, do not simply modify the value of the \ttt{nf} variable by hand +--- when you call \ttt{qcd\_SetNf} is adjusts a whole set of other +constants (\eg the $\beta$ function coefficients) appropriately. + +There are situations in which it's of interest to vary the other +colour factors of QCD --- for that purpose, use +\begin{verbatim} + real(dp) :: ca_lcl, cf_lcl, tr_lcl + call qcd_SetGroup(ca_lcl, cf_lcl, tr_lcl) +\end{verbatim} +Again all other constants in the \ttt{qcd} module will be adjusted. A +word of caution: the NNLO splitting functions actually depend on a +colour structure that goes beyond the usual $C_A$, $C_F$ and $T_R$, +namely $d_{abc}d^{abc}$. The means for setting this have yet to be +implemented. \comment{Fix this?} + + +A comment regarding normalizations: nearly everything perturbative in +\hoppet is defined to be a coefficient of $\as/2\pi$. The one +exception is the $\beta$-function coefficients: +\begin{equation} + \label{eq:as-ev} + \frac{d\as}{d\ln Q^2} = -\as (\ttt{beta0}\cdot \as + + \ttt{beta1}\cdot \as^2 + + \ttt{beta2} \cdot\as^3). +\end{equation} +There's no good reason for this. \comment{But now's not the time to + change it.} + +%...................................................................... +\subsubsection{DGLAP splitting matrices} +\label{sec:dglap-split} + +The module \ttt{dglap\_objects} includes a number of routines for +providing access to the \ttt{split\_mat} objects corresponding to +DGLAP splitting functions +\begin{verbatim} + type(split_mat) :: P_LO, P_NLO, P_NNLO + type(split_mat) :: Pp_LO, Pp_NLO ! polarized + + ! MSbar unpolarized case + call InitSplitMatLO (grid, P_LO) + call InitSplitMatNLO (grid, P_NLO) + call InitSplitMatNNLO(grid, P_NNLO) + + ! the MSbar polarized case... + call InitSplitMatPolLO (grid, Pp_LO) + call InitSplitMatPolNLO(grid, Pp_NLO) +\end{verbatim} +In each case the splitting function is set up for the $n_f$ and +colour-factor values that are current in the $\ttt{qcd}$ module, as +set with the $qcd\_SetNf$ and $qcd\_SetGroup$ subroutine calls. If one +subsequently resets the $n_f$ or color factor values, the $split\_mat$ +objects continue to correspond to the $n_f$ and colour factor values +for which they were initially calculated. + +With the above subroutines for initializing DGLAP splitting functions, +the normalisation is such that +\begin{equation} + \label{eq:dpdf} + \frac{dq}{d\ln Q^2} \equiv \frac{dq}{dt} = \frac{\as}{2\pi}\, + \ttt{P\_LO} \otimes q + + \left(\frac{\as}{2\pi}\right)^2 \ttt{P\_NLO} + \otimes q + \ldots +\end{equation} +In practice because convolutions take a time $\order{N^2}$ whereas +additions and multiplications take a time $\order{N}$, in a program it +is better to first sum the splitting matrices and then carry out the +convolution, +\begin{verbatim} + type(split_mat) :: P_sum + real(dp), pointer :: q(:,:), dq + [ ... ] + call InitSplitMat(P_sum, P_LO) ! P_sum = P_LO + call AddWithCoeff(P_sum, P_NLO, as2pi) ! P_sum = P_sum + as2pi * P_NLO + dq = (as2pi * dt) * (P_sum .conv. q) + call Delete(P_sum) +\end{verbatim} +Note the use of brackets in the line setting \ttt{dq}: all scalar +factors are first multiplied together ($\order{1}$) so that we only +have one multiplication of a PDF ($\order{N}$). Note also that we have +chosen to include the \ttt{(as2pi * dt)} factor as multiplying the +pdf, rather than the other option of multiplying {P\_sum}, \ie +\begin{verbatim} + call Multiply(P_sum, (as2pi * dt)) + dq = P_sum .conv. q +\end{verbatim} +The result would have been identical, but splitting matrices with +positive interpolation \ttt{order} essentially amount to an +$\order{7\times \ttt{order} \times N}$ sized array, whereas the PDF is +an $\order{13 N}$ sized array and the for high positive orders that +are sometimes used, it is cheaper to multiply the latter. + +A remark concerning NNLO splitting functions: the exact NNLO splitting +functions derived by Moch, Vermaseren and Vogt +\cite{NNLO-NS,NNLO-singlet} involve long (multi-page) expressions in +terms of harmonic polylogarithms of up to weight 4. Very conveniently, +refs.~\cite{NNLO-NS,NNLO-singlet} provide the expressions directly in +terms of fortran code. +% +The harmonic polylogarithms can be evaluated using the \ttt{hplog} +package of Gehrmann and Remiddi \cite{FortranPolyLog}, a copy of which +is included with the \hoppet package. + +The initial integrations needed to create the \ttt{split\_mat} objects +for the exact NNLO splitting functions for the full range of $n_f$ +take of the order of minutes. Since currently there is no option of +storing the splitting matrices in a file, this can be a bit +bothersome. So instead, by default, the program uses the approximate, +parameterized NNLO splitting functions also provided in +\cite{NNLO-NS,NNLO-singlet}. The parameterized splitting functions are +guaranteed to be accurate to within $0.1\%$ --- in practice since they +come in relatively suppressed by two powers of $\as$, the impact on +the evolution tends to be of the order $10^{-5}$ relative effect +\cite{Benchmarks}. + +The user can choose whether to obtain the exact or parameterized NNLO +splitting functions using the following calls (to be made before +initialising the splitting matrices) +\begin{verbatim} + integer :: splitting_variant + call dglap_Set_nnlo_splitting(splitting_variant) +\end{verbatim} +with the following variants defined (as integer parameters) in the +module \ttt{dglap\_choices}: +\begin{verbatim} + nnlo_splitting_exact + nnlo_splitting_param [default] + nnlo_splitting_Nfitav + nnlo_splitting_Nfiterr1 + nnlo_splitting_Nfiterr2 +\end{verbatim} +The last 3 are the parameterizations based on fits to reduced moment +information carried out in \cite{vanNeerven:1999ca,vanNeerven:2000uj}. +Though at the time they represented a valuable (and much used) step on +the way to full NNLO results, nowadays their interest is mainly +historical. + +Note that only for the \ttt{nnlo\_splitting\_exact} can the colour +constants be varied (with the caveat about $d^{abc}d_{abc}$). + + + +%...................................................................... +\subsubsection{Mass threshold matrices} +\label{sec:mtm} + +Still in the \ttt{dglap\_objects} module, we have a type dedicated to +crossing mass thresholds. +\begin{verbatim} + type(grid_def) :: grid + type(mass_threshold_mat) :: MTM_NNLO + + call InitMTMNNLO(grid, MTM_NNLO) ! MTM_NNLO is coeff of (as/2pi)**2 +\end{verbatim} +This is the coefficient, calculated by Buza et al. \cite{NNLO-MTM} +(the authors are thanked for the code corresponding to the +calculation), of $(\as/2\pi)^2$ for the convolution matrix that +accounts for crossing a heavy flavour threshold in $\MSbar$ +factorization scheme, at $\mu_F = M_H^\mathrm{pole}$, where +$M_H^\mathrm{pole}$ is the heavy-quark pole mass. Since the +corresponding NLO term is zero, the number of flavours in $\as$ is +immaterial at NNLO (even at NNNLO). + +The treatment of $n_f$ in the \ttt{mass\_threshold\_mat} is very +specific because at NNLO, the only order in the $\MSbar$ factorization +scheme at which it's non-zero and known, it is independent of $n_f$. +It's action does of course however depend on $n_f$. Since, as for +\ttt{split\_mat} objects, we don't want to the action of of the +\ttt{mass\_threshold\_mat} to depend on the availability of the +current $n_f$ information from the \ttt{qcd} module, instead we +require that before using a \ttt{mass\_threshold\_mat}, you should +explicitly indicate the number of flavours (defined as including the +new heavy flavour). This is done using a call to the +\ttt{SetNfMTM(MTM\_NNLO,nf\_incl\_heavy)} subroutine. So for example +to take a pdf from 3 flavours to 4 at $\mu_F = M_H^\mathrm{pole}$ one +uses code analogous to the following +\begin{verbatim} + real(dp) :: pdf_nf3(:,:), pdf_nf4(:,:) + [ ... ] + call SetNfMTM(MTM, 4) + pdf_nf4 = pdf_nf3 + (as2pi)**2 * (MTM_NNLO.conv.pdf_nf3) +\end{verbatim} +The convolution only works if the \ttt{pdf}'s are in the \ttt{human} +representation and an error is given if this is not the case. Any +heavy flavour (charm) present in \ttt{pdf\_nf3} is ignored. + +Note that this type is not currently suitable for general changes of +flavour-number. For example if you wish to carry out a change in the +DIS scheme or at a scale $\mu_F \neq M_H^\mathrm{pole}$ then you have +to combine a series of different convolutions (essentially correcting +with the lower number of flavours to the $\MSbar$ factorization scheme +at $\mu_F = M_H^\mathrm{pole}$ before changing the number of flavours +and then correcting back to the original scheme and scale using the +higher number of flavours). + + +As for the NNLO splitting functions, the mass threshold corrections +come in exact and parameterized variants. By default it is the latter +that is used (provided by Vogt \cite{VogtMTMParam}). The cost of +initializing with the exact variants of the mass thresholds is much +lower than for the exact NNLO splitting functions (partly because +there is no $n_f$ dependence, partly because it is only one flavour +component of the mass-threshold function that is complex enough to +warrant parameterization). The variant can be chosen by the user +before initialising the \ttt{mass\_threshold\_mat} by making the +following subroutine call: +\begin{verbatim} + integer :: threshold_variant + call dglap_Set_nnlo_nfthreshold(threshold_variant) +\end{verbatim} +with the following variants defined (as integer parameters), again in +the module \ttt{dglap\_choices}: +\begin{verbatim} + nnlo_nfthreshold_exact + nnlo_nfthreshold_param [default] +\end{verbatim} + + +%...................................................................... +\subsubsection{Putting it together: \ttt{dglap\_holder}} + +The discussion so far in this subsection was intended to provide the +reader with an overview of the different DGLAP components that have +been implemented and of how they can be initialised individually. This +is useful above all if the user needs to tune the program to some +specific unusual application. + +In practice, one foresees that most users will need just a standard +DGLAP evolution framework, and so will prefer not to have to manage +all these components individually. Accordingly \hoppet provides a +type, $\ttt{dglap\_holder}$ which holds all the components needed for +a given kind of evolution. To initialize all information for a +fixed-flavour number evolution, one does as follows +% +\begin{verbatim} + use hoppet_v1 + type(dglap_holder) :: dglap_h + integer :: factscheme, nloop, nf_lcl + + nloop = 3 ! NNLO + factscheme = factscheme_MSbar ! or: factscheme_DIS; factscheme_PolMSbar + call qcd_SetNf(4) ! set the fixed number of flavours + ! call qcd_SetGroup(...) ! if you want different colour factors + + ! now do the initialization + call InitDglapHolder(grid, dglap_h, factscheme, nloop) +\end{verbatim} +The constants \ttt{factscheme\_*} are defined in \ttt{module + dglap\_choices}. % +The corrections to the splitting functions to get the DIS scheme are +implemented by carrying out appropriate convolutions of the $\MSbar$ +splitting and coefficient functions. Currently the DIS scheme is only +implemented to NLO. (It's NNLO implementation would actually be fairly +straightforward given the parameterizations provided in +\cite{White:2005wm}) The polarised splitting functions are only known +to NLO. + +Initialization can also be carried out with a single call go for a range of +different numbers of flavours: +\begin{verbatim} + integer :: nflo, nfhi + [...] + nflo = 3; nfhi = 6 ! [calls to qcd_SetNf handled automatically] + call InitDglapHolder(grid, dglap_h, factscheme, nloop, nflo, nfhi) +\end{verbatim} +Mass thresholds are not currently correctly supported in the DIS +scheme. + +For all the above calls, at NNLO the choice of exact of parameterized +splitting functions and mass thresholds is determined by the calls to +\ttt{dglap\_Set\_nnlo\_splitting} and +\ttt{dglap\_Set\_nnlo\_nfthreshold}, as described in +sections~\ref{sec:dglap-split}, \ref{sec:mtm} respectively. These +calls must be made prior to the call to \ttt{InitDglapHolder}. + +Having initialised a \ttt{dglap\_holder} one has access to various components: +\begin{verbatim} + type dglap_holder + type(split_mat), pointer :: allP(1:nloop, nflo:nfhi) ! FFNS: nflo=nfhi=nf_lcl + type(split_mat), pointer :: P_LO, P_NLO, P_NNLO + type(mass_threshold_mat) :: MTM2 + logical :: MTM2_exists + integer :: factscheme, nloop + integer :: nf + [ ... ] + end type dglap holder +\end{verbatim} +Some just record information passed on initialisation, for example +\ttt{factscheme} and \ttt{nloop}. Other parts are set up once and for +all on initialisation, notably the \ttt{allP} matrix, which contains +the 1-loop, 2-loop, etc. splitting matrices for the requested $n_f$ +range. + +Yet other parts of the \ttt{dglap\_holder} type depend on $n_f$. +Before accessing these, one should first perform the following call: +\begin{verbatim} + call SetNfDglapHolder(dh, nf_lcl) +\end{verbatim} +This creates links: +\begin{verbatim} + dh%P_LO => dh%allP(1,nf_lcl) + dh%P_NLO => dh%allP(2,nf_lcl) + dh%P_NNLO => dh%allP(3,nf_lcl) +\end{verbatim} +for convenient named access to the various splitting matrices, and it +also sets the global (\ttt{qcd}) $n_f$ value (via a call to +\ttt{qcd\_SetNf}) and where relevant updates the internal $n_f$ value +associated with \ttt{MTM2} (via a call to \ttt{SetNfMTM}). + +As with other types that allocate memory for derived types, that +memory can be freed via a call to the \ttt{Delete} subroutine, +\begin{verbatim} + call Delete(dh) +\end{verbatim} + +%====================================================================== +%====================================================================== +\section{Renormalisation Group Evolution} + +\comment{We slowly approach our objective} + + +%---------------------------------------------------------------------- +\subsection{Running coupling} +\label{sec:run-coupl} + +Before carrying out any DGLAP evolutions, one first needs to set up a +a \ttt{running\_coupling} object (defined in \ttt{module + qcd\_coupling}): +\begin{verbatim} + type(running_coupling) :: coupling + real(dp) :: alfas, Q, quark_masses(4:6), muMatch_mQuark + integer :: nloop, fixnf + + [... set parameters ...] + call InitRunningCoupling(coupling [, alfas] [, Q] [, nloop] [, fixnf]& + & [, quark_masses] [, muMatch_mQuark]) +\end{verbatim} +As can be seen, many of the arguments are optional. Their default +values are as follows: +\begin{verbatim} + alfas = 0.118_dp + Q = 91.2_dp + nloop = 2 + fixnf = [.not. present] + ! charm, bottom, top + quark_masses(4:6) = (/ 1.414213563_dp, 4.5_dp, 175.0_dp /) + muMatch_mQuark = 1.0_dp +\end{verbatim} +The running coupling object is initialised so that at scale \ttt{Q} +the coupling is equal to \ttt{alfas}. The running is carried out with +the \ttt{nloop} $\beta$-function. If the \ttt{fixnf} argument is +present, then the number of flavours is kept fixed at that +value. Otherwise flavour thresholds are implemented at scales +\begin{verbatim} + muMatch_mQuark * quark_masses(4:6) +\end{verbatim} +where the quark masses are \emph{pole} masses. The choice to use pole +masses (and their particular default values) is inspired by the +benchmark runs~\cite{Benchmarks} in which \hoppet results were +compared to those of Vogt's moment-space code +QCD-Pegasus~\cite{Pegasus}. + +To access the coupling at some scale \ttt{Q} one uses the following +function call: +\begin{verbatim} + alfas = Value(coupling, Q [, fixnf]) +\end{verbatim} +This is the value of the coupling as obtained from the Runge-Kutta +solution of the \ttt{nloop} version of eq.(\ref{eq:as-ev}) (the +evolution is actually carried out for $1/\as$), together with the +appropriate mass thresholds \cite{coupling_mass_thresholds}. For +typical values of $\as(M_Z)$ the coupling is guaranteed to be reliably +determined in the range $0.5 \GeV < Q < 10^{19}\GeV$. The values of +the $\beta$ function coefficients used in the evolution correspond to +those obtained with the values of the QCD colour factors that were in +vigor at the moment of initialisation of the coupling. + +In the variable flavour-number case, the \ttt{fixnf} argument allows +one to obtain the coupling for \ttt{fixnf} flavour even outside the +natural range of scales for that number of flavours. This is only +really intended to be used close to the natural range of scales, and +can be slow if one goes far from that range (a warning message will be +output). If one is interested in a coupling that (say) never has more +than 5 active flavours, then rather than using the \ttt{fixnf} option +in the \ttt{Value} subroutine, it is best to initialize the coupling +with a fictitious large value for the top mass. + +Often it is convenient to be able to enquire about the mass information +embodied in a \ttt{running\_coupling}. For example in the PDF +evolution below, all information about the location of mass thresholds is +obtained from the \ttt{running\_coupling} type. + +The quark pole mass for flavour \ttt{iflv} can be obtained with the +call +\begin{verbatim} + pole_mass = QuarkMass(coupling, iflv) +\end{verbatim} +The range of scales, $\ttt{Qlo} < Q < \ttt{Qhi}$ for which \ttt{iflv} +is the heaviest active flavour is obtained by the subroutine call +\begin{verbatim} + call QRangeAtNf(coupling, iflv, Qlo, Qhi [, muM_mQ]) +\end{verbatim} +The optional argument \ttt{muM\_mQ} allows one to obtain the answer as +if one had initialised the coupling with a different value of +\ttt{muMatch\_mQuark} than that actually used. One can also establish +the number of active flavours, \ttt{nf\_active}, at a given scale +\ttt{Q} with the following function: +\begin{verbatim} + nf_active = NfAtQ(coupling, Q [, Qlo, Qhi] [, muM_mQ]) +\end{verbatim} +As well as returning the number of active flavours, it can also set +\ttt{Qlo} and \ttt{Qhi}, which correspond to the range of scales in +which the number of active flavours is unchanged. The optional +\ttt{muM\_mQ} argument has the same purpose as in the \ttt{QRangeAtNf} +subroutine. The last of the enquiry functions allows one to obtain the +range of number of flavours covered in this coupling, $\ttt{nflo} \le +n_f \le \ttt{nfhi}$: +\begin{verbatim} + call NfRange(coupling, nflo, nfhi) +\end{verbatim} + +Finally, as usual, once you no longer need a \ttt{running\_coupling} +object, you may free the memory associated with it using the +\ttt{Delete} call: +\begin{verbatim} + call Delete(coupling) +\end{verbatim} + + + +%---------------------------------------------------------------------- +\subsection{DGLAP evolution} +\label{sec:dglap-ev} + + +%...................................................................... +\subsubsection{Direct evolution} +\label{sec:direct-evolution} + +We are now ready to evolve a PDF. This is done by breaking the +evolution into steps, and for each one using a Runge-Kutta +approximation for the solution of a first-order matrix differential +equation. The steps are of uniform size in a variable $u$ that +satisfies the following approximate relation +\begin{equation} + \label{eq:du} + \frac{du}{d\ln Q^2} \simeq \as(Q^2) +\end{equation} +For a 1-loop running coupling one has $u = (\ln \ln +Q^2/\Lambda)/\beta_0$, which is the variable that appears in +analytical solutions to the $1$-loop DGLAP equation. +% +The step size in du can be set with the following call +\begin{verbatim} + real(dp) :: du = 0.1_dp ! or some smaller value + call SetDefaultEvolutionDu(du) +\end{verbatim} +The error on the evolution from the finite step size should scale as +$(\ttt{du})^4$. With the default value of $\ttt{du}=0.1$, errors are +typically somewhat smaller than $10^{-3}$ (see +section~\ref{sec:benchmarks} for the detailed benchmarks). + +To actually carry out the evolution, one uses the following subroutine +call: +\begin{verbatim} + call EvolvePDF(dh, pdf, coupling, Q_init, Q_end & + & [, muR_Q] [, nloop] [, untie_nf] ) +\end{verbatim} +which takes a \ttt{pdf} uses the splitting matrices in \ttt{dh}, to +evolve it from scale \ttt{Q\_init} to scale \ttt{Q\_end} +% +By default the renormalisation to factorisation scale ratio is +$\ttt{muR\_Q} = 1.0$ and the number of loops in the evolution is the +same as was used for the running \ttt{coupling} (the \ttt{nloop} +optional argument makes it possible to override this choice). Variable +flavour-number switching takes place at the pole masses (maybe one day +this restriction will be lifted) as associated with the +\ttt{coupling}. + +If the \ttt{dglap\_holder} object \ttt{dh} does not support the +relevant number of loops or flavours, the program will give an error +message and stop. With the \ttt{untie\_nf} option you can request that +the number of flavours in the evolution be `untied' from that in the +coupling in the regions where \ttt{dh} does not support the number of +flavours used in the coupling. Instead the closest number of flavours +will be used.\footnote{For example if \ttt{dh} was initialised with + $n_f = 3\ldots5$ while the coupling has $n_f = 3\ldots 6$, then + variable flavour number evolution will be used up to $n_f = 5$, but + beyond the top mass the evolution will carry on with $5$ flavours, + while the coupling uses $6$ flavours. There probably aren't too many + good reasons for doing this (other than for examining how much it + differs from a `proper' procedure).} + +Mass thresholds (NNLO) are implemented as +\begin{subequations} +\label{eq:mass_threshold} +\begin{align} + \ttt{pdf}_{n_f} &= \ttt{pdf}_{n_f-1} + + \left(\frac{\alpha_{s,n_f}(x_\mu M)}{2\pi}\right)^2 + (\mbox{\ttt{dh\%MTM2 .conv.}}\; \ttt{pdf}_{n_f-1})\\ + % + \ttt{pdf}_{n_f-1} &= \ttt{pdf}_{n_f} \;\;\;\;+ + \left(\frac{\alpha_{s,n_f}(x_\mu M)}{2\pi}\right)^2 + (\mbox{\ttt{dh\%MTM2 .conv.}}\; \ttt{pdf}_{n_f}) +\end{align} +\end{subequations} +when crossing the threshold upwards and downwards, respectively. Note +that the two operations are not perfect inverses of each other, +because the number of flavours of the \ttt{pdf} used in the +convolution differs in the two cases. The mismatch however is only of +order $\as^4$ (NNNNLO), \ie well beyond currently known accuracies. + +A general remark is that crossing a flavour threshold downwards will +nearly always result in some (physically spurious?) intrinsic +heavy-flavour being left over below threshold. + +%...................................................................... +\subsubsection{Precomputed evolution and the \ttt{evln\_operator}} +\label{sec:precomputed-evolution} + +Each Runge-Kutta evolution step involves multiple evaluations of the +derivative of the PDF, and the evolution between two scales may be +broken up into multiple Runge-Kutta steps. This amounts to a large +number of convolutions. It can therefore be useful to create a single +\emph{derived} splitting matrix that is equivalent to the whole +evolution between the two scales. + +A complication arises because evolutions often cross flavour +thresholds, whereas a derived splitting matrix is only valid for fixed +$n_f$. Therefore a new type has to be created, \ttt{evln\_operator}, +which consists of a linked list of splitting and mass threshold +matrices, breaking an evolution into a chain of interleaved +fixed-flavour evolution steps and flavour changing steps. An +\ttt{evln\_operator} is created with a call that is almost identical +to that used to evolve a PDF: +\begin{verbatim} + type(evln_operator) :: evop + real(dp), pointer :: pdf_init(:,:), pdf_end(:,:) + [...] + call InitEvlnOperator(dh, evop, coupling, Q_init, Q_end & + & [, muR_Q] [, nloop] [, untie_nf] ) +\end{verbatim} +It can then be applied to PDF in the same way that a normal +\ttt{split\_mat} would: +\begin{verbatim} + pdf_end = evop * pdf_init ! assume both pdfs already allocated + ! OR (alternate form) + pdf_end = evop .conv. pdf_init +\end{verbatim} +As usual the \ttt{Delete} subroutine can be used to clean up any +memory associated with an evolution operator that is no longer needed. + + +%====================================================================== +%====================================================================== +\section{Tabulated PDFs} +\label{sec:tabulated-pdfs} + +Lots of name changes will be needed here... + +%====================================================================== +%====================================================================== +\section{Vanilla interface} +\label{sec:vanilla} + + +%====================================================================== +%====================================================================== +\section{Benchmarks and timings} +\label{sec:benchmarks} + + +Comparisons to $N$-space codes (especially Vogt): + +\begin{itemize} +\item $N$-space is good for a moderate (few hundred) number of $x$-$Q$ + points (for lots of points, better to convert it to tabulation) +% +\item For $\sim 500$ points, $N$-space is faster for the same + accuracy, and its running times probably scale much more tamely when + you try to go to extremely high accuracies. +% +\item Nevertheless, for reference purposes the $x$-space code can also + go to high accuracies ($10^{-7}$) if you're willing to accept slow + runs. +% +\item At accuracies that are acceptable for phenomenology ($10^{-3} - + 10^{-4}$) the $x$-space code runs nearly as fast as Vogt's $N$-space + code in its lower accuracy option (which is still better accuracy + than the $x$-space code). But overheads are different --- evolution + is a one-off operation, accessing points is then done using + interpolation. +% +\item $N$-space isn't an option if you don't have a simple analytic + form for your initial parton distributions. +% +\item currently no other code has the option of the exact NNLO + splitting functions. +\end{itemize} + +%====================================================================== +\appendix + +%====================================================================== +\section{Useful tips on fortran~95} +\label{sec:f95appendix} + +As fortran~95's use in high-energy physics is not as widespread as +that of other languages such as fortran~77 and C++, it is useful to +summarise some key novelties compared to fortran~77, as well as some +points that might otherwise cause confusion. For further information +the reader is referred both to books about the language such as +\cite{F95Explained} and to web resources~\cite{F95WebResources}. + +\paragraph{Free form.} Most of the code in the \hoppet package is in +free-form. The standard extension for free-form form files is +\ttt{.f90}. There is no requirement to leave 6 blank spaces before +every line and lines can consist of up to 132 characters. The other +main difference relative to f77 fixed form is that to continue a line +one must append an append an ampersand, \ttt{\&}, to the line to be +continued. One may optionally include an ampersand as the first +non-space character of the continuation line. + +For readibility, many of the subprogram names in this documentation +are written with capitals at the start of each word. Note however that +free-form fortran~95, like its fixed-form predecessors, is case +insensitive. + +\paragraph{Modules, and features relating to arrays.} Fortran~90/95 +allows one to package variables and subroutines into modules +\begin{verbatim} +module test_module + implicit none + integer :: some_integer +contains + subroutine print_array(array) + integer, intent(in) :: array(:) ! size is known, first element is 1 + ! intent(in) == array will not be changed + integer :: i, n + n = size(array) + do i = 1, n + print *, i, array(i) + end do + end subroutine hello_world +end module test_module +\end{verbatim} +The variable \texttt{some\_integer} and the subroutine +\texttt{print\_array} are invisible to other routines unless they +explicitly \texttt{use} the module as in the following example: +\begin{verbatim} +program test_program + use test_module + implicit none + integer :: array1(5), array2(-2:2) + integer :: i + + some_integer = 5 ! set the variable in test_module + array1 = 0 ! set all elements of array1 to zero + array2(-2:0) = 99 ! set elements 1..3 of array2 to equal to 3. + array2(1:2) = 2*array2(-1:0) ! elements -2..0 equal twice elements -1..0 + + print *, "Printing array 1" + call print_array(array1) + print *, "Printing array 2" + call print_array(array2) +end program test_program +\end{verbatim} +Constants can be assigned to arrays (\texttt{array1}) or array +subsections (\texttt{array2(-2:0)}), arrays can be assigned to arrays +of the same size (as is done for \texttt{array2(-2:0)}) and +mathematical operations apply to each element of the array (as with +the multiplication by 2). + +When arrays are passed to function or subroutine that is defined in a +\texttt{use}d module, information about the size of the array is +passed along with the array itself. Note however that information +about the lower bound is \emph{not} passed, so that for both +\texttt{array1} and \texttt{array2}, \texttt{print\_array} will see +arrays whose valid indices will run from $1\ldots5$. Thus the output +from the program will be +\begin{verbatim} + Printing array 1 + 1 0 + 2 0 + 3 0 + 4 0 + 5 0 + Printing array 2 + 1 99 + 2 99 + 3 99 + 4 198 + 5 198 +\end{verbatim} +If \texttt{print\_array} wants \texttt{array} to have a different lower +bound it must specify it in the declaration, for example +\begin{verbatim} + integer, intent(in) :: array(-2:) ! size is known, first element is -2 +\end{verbatim} +While it may initially seem bizarre, there are good reasons for such +behaviour (for example in allowing a subroutine to manipulate multiple +arrays of the same size without having to worry about whether they all +have the same lower bounds). + +\paragraph{Dynamic memory allocation, pointers.} One of the major +additions of f95 compared to f77 is that of dynamic memory allocation, +for example with pointers +\begin{verbatim} + integer, pointer :: dynamic_array(:) + allocate(dynamic_array(-6:6)) + ! .. work with it .. + deallocate(dynamic_array) +\end{verbatim} +This is fundamental to our ability to decide parameters of the PDF +grid(s) at runtime. Pointers can be passed as arguments to subprograms. +If the subprogram does not specify the \texttt{pointer} attribute for +the dummy argument +\begin{verbatim} +subroutine xyz(dummy_array) + integer, intent(in) :: dummy_array(:) +\end{verbatim} +then everything behaves as if the argument were a normal array (\eg +the default lower bound is $1$). Alternatively the subroutine can +specify that it expects a pointer argument +\begin{verbatim} +subroutine xyz(dummy_pointer_array) + integer, pointer :: dummy_pointer_array(:) +\end{verbatim} +In this case the subroutine has the freedom to allocate and deallocate +the array. Note also that because a pointer to the full array +information is being passed, the lower bound of \texttt{dummy\_pointer\_array} +is now the same as in the calling routine. Though this sounds like a +technicality, it is important because a corollary it that a subroutine +can allocate a dummy pointer array with bounds that are passed back to +the calling subroutine (we need this for the flavour dimension of +PDFs, whose lower bound is most naturally $-6$). + +Note that in contrast to \ttt{C}/\ttt{C++} pointers, f90 pointers do +not explicitly need to be dereferenced --- in this respect they are +more like \ttt{C++} \emph{references}. To associate a pointer with an +object, one uses the \ttt{=>} syntax: +\begin{verbatim} + integer, target :: target_object(10) + integer, pointer :: pointer_to_object(:) + pointer_to_object => target_object + pointer_to_object(1:10) = 0 ! sets target_object(1:10) +\end{verbatim} +One notes that the object that was pointed to had the \ttt{target} +attribute --- this is mandatory (unless the object is itself a +pointer). + + +\paragraph{Derived types.} Another feature of f95 that has been +heavily used is that of derived types (analogous to C's +\texttt{struct}): +\begin{verbatim} + type pair + integer first, second + end type pair +\end{verbatim} +Variables of this type can then be created and used as follows +\begin{verbatim} + type(pair) :: pair_object, another_pair_object + pair_object%first = 1 + pair_object%second = 2 + another_pair_object = pair_object + print *, another_pair_object%second +\end{verbatim} +where one sees that the entirety of the object can be copied with the +assignment (\texttt{=}) operator. Note that many of the derived types +used in \hoppet contain pointers and when such a derived type object +is copied, the copy's pointer just points to the same memory as the +original object's pointer. This is sometimes what you want, but on +other occasions will give unexpected behaviour: for example splitting +function types are derived types containing pointers, so when you +assign one splitting function object to another, they end up referring +to the same memory, so if you multiply one of them by a constant, the +other one will also be modified. + +\paragraph{Operator overloading} While assignment behaves more or less +as expected by default with derived types (it can actually be modified +if one wants to), other operators do not have default definitions. So +if one wants to define, say, a multiplication of objects one may +associate a function with a given operator, using an interface block: +\begin{verbatim} +module test_module + interface operator(*) ! provide access to dot_pairs through + module procedure dot_pairs ! the normal multiplication symbol + end interface + interface operator(.dot.) ! provide acecss to dot_pairs through + module procedure dot_pairs ! a specially named operator + end interface +contains + integer function dot_pairs(pair1, pair2) + type(pair), intent(in) :: pair1, pair2 + dot_pairs = pair1%first*pair2%first + pair1%second*pair2%second + end function dot_pairs +end module +\end{verbatim} +given which we can then write +\begin{verbatim} + integer :: i + type(pair) :: pair1, pair2 + [... some code to set up pair values ...] + ! now multiply them + i = pair1 * pair2 + i = pair1 .dot. pair2 ! equivalent to previous statement +\end{verbatim} +Since the the multiplication operator (\texttt{*}) already exists for +all the default types, by defining it for a new type we have +\emph{overloaded} it. Note that there are some subtleties with +precedences of user-defined operators: operators (like \texttt{*}) +that already exist have the same precedence as they have is usual +operators; operators that do not exist by default (\texttt{.dot}) have +the lowest possible preference, so, given the above definitions, +\begin{verbatim} + i = 2 + pair1 * pair2 ! legal + i = 2 + pair1 .dot. pair2 ! illegal, means: (2+pair1).dot.pair2 + i = 2 + (pair1 .dot. pair2) ! legal +\end{verbatim} +where the second line is illegal because we have not defined any +operator for adding an integer and a pair. Similarly care is needed +when using the \hoppet's operator \texttt{.conv.}. + +\paragraph{Floating point precision:} +A final point concerns floating point variable types. Throughout we +have used definitions such as +\begin{verbatim} + real(dp), pointer :: pdf(:,:) +\end{verbatim} +and written numbers with a trailing \texttt{\_dp} +\begin{verbatim} + param = 1.7_dp +\end{verbatim} +Here \texttt{dp} is an integer parameter (defined in the +\texttt{types} module and accessible also through the +\texttt{hoppet\_v1} module), which specifies the \texttt{kind} of real +that we want to define, specifically double precision. We could also +have written \texttt{double precision} everywhere, but this is less +compact, and the use of a kind parameter has the advantage that we +can just modify its definition in one point in the program and the +precision will be modified everywhere. (Well, almost, since some +special functions are written in fortran~77 using \texttt{double + precision} declarations and do their numerics based on the +assumption that that truly is the type they're dealing with). + + +\paragraph{Optional and keyword arguments} + + +%====================================================================== +\begin{thebibliography}{99} + +% about 1 minute at NLO. +\bibitem{coriano} A.~Cafarella and C.~Coriano, +%``Direct solution of renormalization group equations of QCD in x-space: NLO +%implementations at leading twist,'' +Comput.\ Phys.\ Commun.\ {\bf 160} (2004) 213 +[arXiv:hep-ph/0311313]. +%%CITATION = HEP-PH 0311313;%% + +% Uses decomposition on Laguerre polynomials -- about +% 30 of them, remains Y^2 * T method. Initialisation +% (transform of splitting functions takes 15s on thalie) +% (didn't try evolution; didn't check accuracy; evolution +% times and accuracy are not mentioned; seemed fixed nf) +\bibitem{Schoeffel:1998tz} +L.~Schoeffel, +%``An elegant and fast method to solve QCD evolution equations, application to +%the determination of the gluon content of the pomeron,'' +Nucl.\ Instrum.\ Meth.\ A {\bf 423} (1999) 439. +%%CITATION = NUIMA,A423,439;%% +See also \url{http://www.desy.de/~schoffel/L_qcd98.html}, +\url{http://www-spht.cea.fr/pisp/gelis/Soft/DGLAP/index.html} + + +\bibitem{Weinzierl:2002mv} +S.~Weinzierl, +%``Fast evolution of parton distributions,'' +Comput.\ Phys.\ Commun.\ {\bf 148} (2002) 314 +[arXiv:hep-ph/0203112]; +%%CITATION = HEP-PH 0203112;%% +%\bibitem{Roth:2004ti} +M.~Roth and S.~Weinzierl, +%``QED corrections to the evolution of parton distributions,'' +Phys.\ Lett.\ B {\bf 590} (2004) 190 +[arXiv:hep-ph/0403200]. +%%CITATION = HEP-PH 0403200;%% + + + +\bibitem{Pascaud:2001bi} +C.~Pascaud and F.~Zomer, +%``A fast and precise method to solve the Altarelli-Parisi equations in x +%space,'' +arXiv:hep-ph/0104013. +%%CITATION = HEP-PH 0104013;%% + +\bibitem{F95Explained} + M. Metcalf and J. Reid, \emph{Fortran 90/95 Explained}, Oxford + University Press, 1996. + +\bibitem{F95WebResources} Many introductions and tutorials about + fortran~90 may be found at + \url{http://dmoz.org/Computers/Programming/Languages/Fortran/Tutorials/Fortran_90_and_95/} + +\bibitem{vanNeerven:1999ca} + W.~L.~van Neerven and A.~Vogt, + %``NNLO evolution of deep-inelastic structure functions: The non-singlet + %case,'' + Nucl.\ Phys.\ B {\bf 568} (2000) 263 + [arXiv:hep-ph/9907472]. + %%CITATION = HEP-PH 9907472;%% + +\bibitem{vanNeerven:2000uj} + W.~L.~van Neerven and A.~Vogt, + %``NNLO evolution of deep-inelastic structure functions: The singlet case,'' + Nucl.\ Phys.\ B {\bf 588} (2000) 345 + [arXiv:hep-ph/0006154]. + %%CITATION = HEP-PH 0006154;%% + +\bibitem{NRf90} + Press {\it et al.}, \emph{Numerical Recipes in Fortran~90}, + Cambridge University Press, 1996. + +\bibitem{LHAPDF} W.~Giele and M.~R.~Whalley, +\url{http://hepforge.cedar.ac.uk/lhapdf/} + + +%\cite{Moch:2004pa} +\bibitem{NNLO-NS} + S.~Moch, J.~A.~M.~Vermaseren and A.~Vogt, + %``The three-loop splitting functions in QCD: The non-singlet case,'' + Nucl.\ Phys.\ B {\bf 688} (2004) 101 + [arXiv:hep-ph/0403192]. + %%CITATION = HEP-PH 0403192;%% + +%\cite{Vogt:2004mw} +\bibitem{NNLO-singlet} + A.~Vogt, S.~Moch and J.~A.~M.~Vermaseren, + %``The three-loop splitting functions in QCD: The singlet case,'' + Nucl.\ Phys.\ B {\bf 691} (2004) 129 + [arXiv:hep-ph/0404111]. + %%CITATION = HEP-PH 0404111;%% + + +\bibitem{FortranPolyLog} + T.~Gehrmann and E.~Remiddi, + %``Numerical evaluation of two-dimensional harmonic polylogarithms,'' + Comput.\ Phys.\ Commun.\ {\bf 144} (2002) 200. + %[hep-ph/0111255]. + %%CITATION = HEP-PH 0111255;%% + + +\bibitem{NNLO-MTM} + M.~Buza, Y.~Matiounine, J.~Smith, R.~Migneron and W.~L.~van Neerven, + %``Heavy quark coefficient functions at asymptotic values $Q~2 \gg m~2$,'' + Nucl.\ Phys.\ B {\bf 472}, 611 (1996) + [arXiv:hep-ph/9601302];\\ + %%CITATION = HEP-PH 9601302;%% +% + M.~Buza, Y.~Matiounine, J.~Smith and W.~L.~van Neerven, + %``Charm electroproduction viewed in the variable-flavour number scheme + %versus fixed-order perturbation theory,'' + Eur.\ Phys.\ J.\ C {\bf 1}, 301 (1998) + [arXiv:hep-ph/9612398]. + %%CITATION = HEP-PH 9612398;%% + +\bibitem{VogtMTMParam} A.~Vogt, private communication. + + +\bibitem{White:2005wm} + C.~D.~White and R.~S.~Thorne, + %``Comparison of NNLO DIS scheme splitting functions with results from exact + %gluon kinematics at small x,'' + Eur.\ Phys.\ J.\ C {\bf 45} (2006) 179 + [arXiv:hep-ph/0507244]. + %%CITATION = HEP-PH 0507244;%% + +\bibitem{Benchmarks} + W.~Giele {\it et al.}, + ``Les Houches 2001, the QCD/SM working group: Summary report,'' + hep-ph/0204316, section 1.3;\\ + %%CITATION = HEP-PH 0204316;%% + M.~Dittmar {\it et al.}, + ``Parton distributions: Summary report for the HERA-LHC workshop,'' + hep-ph/0511119, section 4.4. + %%CITATION = HEP-PH 0511119;%% + + +\bibitem{Pegasus} + A.~Vogt, + %``Efficient evolution of unpolarized and polarized parton distributions with + %QCD-PEGASUS,'' + Comput.\ Phys.\ Commun.\ {\bf 170} (2005) 65 + [arXiv:hep-ph/0408244]. + %%CITATION = HEP-PH 0408244;%% + +\end{thebibliography} +\end{document} diff --git a/example_f77/Makefile b/example_f77/Makefile new file mode 100644 index 0000000..86ecda1 --- /dev/null +++ b/example_f77/Makefile @@ -0,0 +1,49 @@ + + + +FC = g77 +FFLAGS = -O + +# BELOW FOLLOW settings that need to be selected according to the f90 +# compiler that was used to compile the library in ../src. If FC above +# is the same as the compiler used for the library, then F90LIB can be +# left empty (but beware, if you used a different compiler, e.g. g77, +# for compiling LHAPDF, you'll need to include a reference to the g77 +# libraries (-L??? -lg2c). + +# for the f90 (lf95) compiler libraries +F90LIB= -L`which lf95 | sed s:bin/lf95:lib:` -lfj9i6 -lfj9f6 -lfj9e6 -lfccx86_6a + +# for the ifort compiler libraries +#F90LIB= -L`which ifort | sed s:bin/ifort:lib:` -lifport -lifcore -limf -lm -lcxa -lirc -lunwind -lc -lirc_s + +# for the g95 compiler libraries -- note that -lfrtbegin is specific +# to the combination of a g77 main program with a g95 library (ensures +# that the g77 "main" is found before the g95 "main") -- with other compilers +# the situation may be different. +#F90LIB= -lfrtbegin -L`locate libf95.a | tail -1 | sed s:/libf95.a::` -lf95 + +# for the gfortran compiler +#F90LIB= -L`locate libgfortran.a | tail -1 | sed s:/libgfortran.a::` -lgfortran +#F90LIB= -L$(HOME)/software/gfortran/lib -lgfortran + + +LIBS = -L$(LHAPDFDIR) -lLHAPDF -L../src -ldglap $(F90LIB) + + +convolution_example: convolution_example.o + $(FC) -o convolution_example $< $(LIBS) + +conveg: conveg.o + $(FC) -o conveg $< $(LIBS) + +test_cteq_lhapdf: test_cteq_lhapdf.o + $(FC) -o test_cteq_lhapdf $< $(LIBS) + + +clean: + rm *.o + +realclean: clean + rm convolution_example conveg + diff --git a/example_f77/convolution_example.f b/example_f77/convolution_example.f new file mode 100644 index 0000000..0261325 --- /dev/null +++ b/example_f77/convolution_example.f @@ -0,0 +1,54 @@ + program convolution_example + implicit none + !--------------- + external evolvePDF + double precision x, Q, lhapdf(-6:6), ourpdf(-6:6) + double precision PLO_conv_ourpdf(-6:6), PNLO_conv_ourpdf(-6:6) + double precision dy + integer iloop, nloop, nf, iflv + + ! initialise an LHAPDF set + call InitPDFsetByName("cteq61.LHgrid") + call InitPDF(0) + + ! start the dglap evolution/convolution package + dy = 0.1d0 ! the internal grid spacing (smaller->higher accuarcy) + ! 0.1 should provide at least 10^{-3} accuracy + nloop = 2 ! the number of loops to initialise (max=3!) + call dglapStart(dy, nloop) + + ! initialise our PDF using the LHAPDF subroutine for PDF-access + ! (any other subroutine with same interface can be used in its place) + call dglapAssign(evolvePDF) + + x = 0.1d0 + Q = 30.0d0 + + ! extract the pdf at this x,Q directly from LHAPDF + call evolvePDF(x,Q,lhapdf) + + ! extract the pdf at this x,Q via our copy of the pdf + call dglapEval(x,Q,ourpdf) + + ! extract the convolution of the 1-loop (LO) splitting function + ! with the currently stored pdf. The normalisation is such that to + ! get the evolution with respect to ln(Q^2) one must multiply + ! PLO_conv_ourpdf by alphas/(2*pi). This is the same thing that + ! in hep-ph/0510324 is referred to as (P_0\otimes q) + iloop = 1 + nf = 5 + call dglapEvalSplit(x,Q,iloop,nf,PLO_conv_ourpdf) + ! extract the convolution with the 2-loop (NLO) splitting function + iloop = 2 + call dglapEvalSplit(x,Q,iloop,nf,PNLO_conv_ourpdf) + + ! print it all + write(6,*) 'x = ', x, ', Q = ', Q + write(6,'(a5,4a17)') 'iflv','lhapdf','ourpdf', + $ 'PLO_conv_ourpdf','PNLO_conv_ourpdf' + do iflv = -6, 6 + write(6,'(i5,4f17.7)') iflv, + $ lhapdf(iflv),ourpdf(iflv), + $ PLO_conv_ourpdf(iflv),PNLO_conv_ourpdf(iflv) + end do + end diff --git a/example_f90/Makefile b/example_f90/Makefile new file mode 100644 index 0000000..656e567 --- /dev/null +++ b/example_f90/Makefile @@ -0,0 +1,64 @@ +# Makefile generated automatically with +# /ada1/lpthe/salam/scripts/makePNEW.perl small_fast_tab -lcern -L../src -ldglap -L/ada1/lpthe/salam/utils/LHAPDF/lib -lLHAPDF -I../src +# default program to compile +PROG = small_fast_tab + +ALLPROG = lha_check_thresh small_fast_tab + +# This will be used one day... +ALLPROGSRC = lha_check_thresh.f90 small_fast_tab.f90 + +ALLPROGOBJ = lha_check_thresh.o small_fast_tab.o + +SRCS = io_utils.f90 lcl_dec.f90 + +POSTSRCS = + +OBJS = io_utils.o lcl_dec.o + +POSTOBJS = +POSTLIB = + +LIBS = -L/maia/cern/2000/lib -L../src -ldglap -L/ada1/lpthe/salam/utils/LHAPDF/lib -lLHAPDF -lmathlib -lkernlib -L/usr/lib/gcc-lib/i386-redhat-linux/3.2.3 -lg2c + +CC = cc +CFLAGS = -O +FC = ifort +FFLAGS = -g -C -I../src +F90 = ifort +F90FLAGS = -g -C -I../src +LDFLAGS = + +# Trick to enable old 'make PROG=xxx' form to still work +all: $(PROG)__ + +$(PROG)__: $(PROG) + +ALL: $(ALLPROG) + +lha_check_thresh: lha_check_thresh.o $(OBJS) $(POSTOBJS) + $(F90) $(LDFLAGS) -o lha_check_thresh lha_check_thresh.o $(OBJS) $(LIBS) $(POSTOBJS) $(POSTLIB) + +small_fast_tab: small_fast_tab.o $(OBJS) $(POSTOBJS) + $(F90) $(LDFLAGS) -o small_fast_tab small_fast_tab.o $(OBJS) $(LIBS) $(POSTOBJS) $(POSTLIB) + +libclean: + rm -f $(ALLPROGOBJS) $(OBJS) $(POSTOBJS) + +clean: + rm -f $(ALLPROGOBJS) $(OBJS) $(POSTOBJS) *.mod *.d + +realclean: + rm -f $(ALLPROG) $(ALLPROGOBJ) $(OBJS) $(POSTOBJS) *.mod *.d + +make: + /ada1/lpthe/salam/scripts/makePNEW.perl small_fast_tab -lcern -L../src -ldglap -L/ada1/lpthe/salam/utils/LHAPDF/lib -lLHAPDF -I../src + +.SUFFIXES: $(SUFFIXES) .f90 + +%.o: %.f90 + $(F90) $(F90FLAGS) -c $< + +io_utils.o: +lha_check_thresh.o: io_utils.o +small_fast_tab.o: io_utils.o diff --git a/example_f90/io_utils.f90 b/example_f90/io_utils.f90 new file mode 100644 index 0000000..340f974 --- /dev/null +++ b/example_f90/io_utils.f90 @@ -0,0 +1,1033 @@ +!! io_utils.f90 +!! +!! version 1.1, GPS, 24 September 2003 +!! +!====================================================================== +!! All the various bits and pieces which could be useful regarding i/o, +!! such as opening the right files, getting numerical values for +!! command line arguments, etc... +!====================================================================== + + +! unfortunate that we need an extra module... +module sub_defs_io_consts + integer, parameter :: max_arg_len = 180 + integer, parameter :: max_line_len = 600 +end module sub_defs_io_consts + + + +!---------------------------------------------------------------------- +!! All the interfaces needed here and in the lcl_???.f90 routines +!---------------------------------------------------------------------- +module sub_defs_io + use sub_defs_io_consts + + interface + subroutine open_arg(iarg, idev, ext, status, form, default_val) + implicit none + integer, intent(in) :: iarg, idev + character(*), optional, intent(in) :: ext, status, form, default_val + end subroutine open_arg + end interface + + interface + function idev_open_opt(opt, default_val, ext, status, form) result(idev) + implicit none + character(*), intent(in) :: opt + character(*), optional, intent(in) :: default_val, ext, status, form + integer :: idev + end function idev_open_opt + end interface + + interface + function idev_open_arg(iarg, ext, status, form) result(idev) + implicit none + integer :: idev + integer, intent(in) :: iarg + character(*), optional, intent(in) :: ext, status, form + end function idev_open_arg + end interface + + interface + function iargc_opt(opt) + implicit none + integer :: iargc_opt + character(len=*), intent(in) :: opt + end function iargc_opt + end interface + + interface + function command_line() + use sub_defs_io_consts + implicit none + character(len=max_line_len) :: command_line + end function command_line + end interface + + interface + function string_val_opt(opt,default_val) + use sub_defs_io_consts + implicit none + character(len=max_arg_len) :: string_val_opt + character(len=*), intent(in) :: opt + character(len=*), intent(in), optional :: default_val + end function string_val_opt + end interface + + interface + function int_val_opt(opt,default_val) + implicit none + integer :: int_val_opt + character(len=*), intent(in) :: opt + integer, intent(in), optional :: default_val + end function int_val_opt + end interface + + interface + function log_val_opt(opt,default_val) + implicit none + logical :: log_val_opt + character(len=*), intent(in) :: opt + logical, intent(in), optional :: default_val + end function log_val_opt + end interface + + interface + function dble_val_opt(opt,default_val) + implicit none + real(kind(1d0)) :: dble_val_opt + character(len=*), intent(in) :: opt + real(kind(1d0)), intent(in), optional :: default_val + end function dble_val_opt + end interface + + interface + integer function value(string) + implicit none + character(*), intent(in) :: string + end function value + end interface + + interface + integer function int_val_arg(argk, default_val) + implicit none + integer, intent(in) :: argk + integer, intent(in), optional :: default_val + end function int_val_arg + end interface + + interface + real(kind(1d0)) function dble_val_arg(argk, default_val) + implicit none + integer, intent(in) :: argk + real(kind(1d0)), intent(in), optional :: default_val + end function dble_val_arg + end interface + + interface + function string_val_arg(argk, default_val) + use sub_defs_io_consts + implicit none + character(len=max_arg_len) :: string_val_arg + integer, intent(in) :: argk + character(len=*), intent(in), optional :: default_val + end function string_val_arg + end interface + + interface + real(kind(1d0)) function dble_value(string) + implicit none + character(*), intent(in) :: string + end function dble_value + end interface + + + interface num2char + function int2char(num,frmt) + implicit none + character(len=30) :: int2char + integer, intent(in) :: num + character(*), intent(in), optional :: frmt + end function int2char + function sp2char(num,frmt) + implicit none + character(len=30) :: sp2char + real(kind(1.0)), intent(in) :: num + character(*), intent(in), optional :: frmt + end function sp2char + function dp2char(num,frmt) + implicit none + character(len=30) :: dp2char + real(kind(1d0)), intent(in) :: num + character(*), intent(in), optional :: frmt + end function dp2char + end interface + + + interface + function get_new_device() result(dev) + implicit none + integer :: dev + end function get_new_device + end interface + + interface + subroutine time_stamp(idev, string) + implicit none + integer, intent(in), optional :: idev + character(len=*), intent(out), optional :: string + end subroutine time_stamp + end interface + + interface + subroutine error_report(subname,line1,line2,line3,line4,action) + implicit none + character(*), intent(in) :: subname + character(*), intent(in), optional :: line1, line2, line3, line4 + character(*), intent(in), optional :: action + end subroutine error_report + end interface + + + !================================================================== + ! ==== + ! Interfaces to the standard routines which provide the links to + ! platform dependent calls + !====================================================================== + + interface + subroutine lcl_write_2d(idev, array) + implicit none + integer, intent(in) :: idev + real(kind(1d0)), intent(in) :: array(1:, 1:) + end subroutine lcl_write_2d + end interface + + interface + subroutine lcl_read_2d(idev, array, ifail) + implicit none + integer, intent(in) :: idev + real(kind(1d0)), intent(out) :: array(1:, 1:) + integer, optional, intent(out) :: ifail + end subroutine lcl_read_2d + end interface + + interface + integer function lcl_iargc() + end function lcl_iargc + end interface + + interface + subroutine lcl_getarg(k, argk) + implicit none + integer, intent(in) :: k + character(*), intent(out) :: argk + end subroutine lcl_getarg + end interface + + interface + subroutine lcl_flush(idev) + implicit none + integer, intent(in) :: idev + end subroutine lcl_flush + end interface + + + interface + function CheckAllArgsUsed(ErrDev) result(check) + logical :: check + integer, optional :: ErrDev + end function CheckAllArgsUsed + end interface + interface + function CheckAllOptsUsed(ErrDev) result(check) + logical :: check + integer, optional :: ErrDev + end function CheckAllOptsUsed + end interface + +end module sub_defs_io + + +!-------------------------------------------------------------- +!! When an argument is used register the fact here. Then at the +!! end of program initialisation one can check to see whether all +!! arguments have been used +module track_args + ! putting the "only" here ensures that this compiles under intel 7.1 + ! (not immediately clear why, though it could be related to fact + ! that interface CheckAllArgsUsed is being used, but that the + ! corresponding subroutine uses track_args?) + use sub_defs_io, only: lcl_iargc, lcl_getarg + use sub_defs_io_consts + implicit none + private + logical, allocatable, save ::argsused(:) + logical :: started = .false. + integer, save :: narg + character(len=*), parameter :: sep = & + &'==============================================================' + + public :: ta_RegisterUsed, ta_CheckAllArgsUsed, ta_CheckAllOptsUsed + +contains + + subroutine ta_RegisterUsed(iarg) + integer, intent(in) :: iarg + if (.not. started) then + narg = lcl_iargc() + allocate(argsused(narg)) + argsused = .false. + started = .true. + end if + + if (iarg > narg .or. iarg < 1) then + write(0,*) 'In ta_RegisterUsed tried to set illegal arg', iarg + stop + end if + argsused(iarg) = .true. + end subroutine ta_RegisterUsed + + + !-------------------------------------------------------- + !! ErrDev = device to which one should send the list of + !! unused args + function ta_CheckAllOptsUsed(ErrDev) result(check) + logical :: check + integer, optional :: ErrDev + integer :: i + character(len=max_arg_len) :: argi + logical :: writeit + + check = .true. + writeit = present(ErrDev) + do i = 1, narg + if (argsused(i)) cycle + call lcl_getarg(i, argi) + if (argi(1:1) == "-") then + if (check .and. writeit) then + write(ErrDev,*) sep + write(ErrDev,*) & + &'WARNING / ERROR: the following options were not recognized' + end if + check = .false. + write(ErrDev,*) trim(argi) + end if + end do + if ((.not. check) .and. writeit ) write(ErrDev,*) sep + end function ta_CheckAllOptsUsed + + + !-------------------------------------------------------- + !! ErrDev = device to which one should send the list of + !! unused args + function ta_CheckAllArgsUsed(ErrDev) result(check) + logical :: check + integer, optional :: ErrDev + integer :: i + character(len=max_arg_len) :: argi + + if (narg > 0 ) then + check = all(argsused) + else + check = .true. + return + end if + if ((.not. check) .and. present(ErrDev)) then + write(ErrDev,*) sep + write(ErrDev,*) & + &'WARNING / ERROR: the following args were not recognized' + do i = 1, narg + if (.not. argsused(i)) then + call lcl_getarg(i, argi) + write(ErrDev,*) trim(argi) + end if + end do + write(ErrDev,*) sep + end if + end function ta_CheckAllArgsUsed + + +end module track_args + + + + +!-------------------------------------------------------- +!! ErrDev = device to which one should send the list of +!! unused args +function CheckAllArgsUsed(ErrDev) result(check) + use track_args + logical :: check + integer, optional :: ErrDev + check = ta_CheckAllArgsUsed(ErrDev) +end function CheckAllArgsUsed +function CheckAllOptsUsed(ErrDev) result(check) + use track_args + logical :: check + integer, optional :: ErrDev + check = ta_CheckAllOptsUsed(ErrDev) +end function CheckAllOptsUsed + + +!---------------------------------------------------------------------- +!! As open_arg -- except that it automatically allocates and returns a +!! device number +!---------------------------------------------------------------------- +function idev_open_arg(iarg, ext, status, form) result(idev) + use sub_defs_io, except => idev_open_arg + implicit none + integer :: idev + integer, intent(in) :: iarg + character(*), optional, intent(in) :: ext, status, form + !-------------------------------------------------------------------- + idev = get_new_device() + call open_arg(iarg, idev, ext, status, form) +end function idev_open_arg + + +!--------------------------------------------------------------------- +!! Open file indicated by command line option and return the +!! device number. +!! +!! GPS 05/01/01 +!--------------------------------------------------------------------- +function idev_open_opt(opt, default_val, ext, status, form) result(idev) + use sub_defs_io, except => idev_open_opt + implicit none + character(*), intent(in) :: opt + character(*), optional, intent(in) :: default_val, ext, status, form + integer :: idev, iarg + !-------------------------------------------------------------------- + idev = get_new_device() + iarg = iargc_opt(opt) + 1 ! will return -100 if opt is not present + if (iarg < 0) then + write(0,*) 'ERROR in idev_open_opt:' + write(0,*) 'command-line option "'//opt//'" missing' + stop + end if + call open_arg(iarg, idev, ext, status, form, default_val) +end function idev_open_opt + + +!---------------------------------------------------------------------- +!! Open file corresponding the name in command line argument 'iarg' +!! +!! GPS 20/03/97 +!---------------------------------------------------------------------- +subroutine open_arg(iarg, idev, ext, status, form, default_val) + use sub_defs_io, only : lcl_getarg, lcl_iargc, max_arg_len, time_stamp + use track_args + implicit none + integer, intent(in) :: iarg, idev + character(*), optional, intent(in) :: ext, status, form, default_val + !---------------------------------------------------------------------- + character(len=max_arg_len) :: arg + integer :: l, le + + l = lcl_iargc() + if (iarg > l .or. iarg < 0) then + if (present(default_val)) then + arg = trim(default_val) + else + write(0,*) 'Number of args is',l + write(0,*) 'Could not open file corresponding to arg',iarg + write(0,*) 'because that arg does not exist' + call time_stamp(0) + write(0,*) 'stop' + stop + end if + else + call lcl_getarg(iarg, arg) + call ta_RegisterUsed(iarg) + end if + + l = index(arg,' ') - 1 + if (present(ext)) then + le = index(ext,' ') - 1 + if (le <= 0) le = len(ext) + arg(l+1:l+le) = ext(1:le) + l = l + le + end if + !-- the following stupid sequence should not be necessary, but the + ! standard doesn't specify open as having `optional args' + if (present(status)) then + if (present(form)) then + open(unit=idev,file=arg(1:l),status=status,form=form) + else + open(unit=idev,file=arg(1:l),status=status) + end if + else + if (present(form)) then + open(unit=idev,file=arg(1:l),form=form) + else + open(unit=idev,file=arg(1:l)) + end if + end if + +end subroutine open_arg + + +!---------------------------------------------------------------------- +!! It can often be useful to have a record of the command line -- this +!! returns a string which conatins the command name and all the arguments +!---------------------------------------------------------------------- +function command_line() + use sub_defs_io, except => command_line + implicit none + character(len=max_line_len) :: command_line + !---------------------------------------------------------------------- + character(len=max_arg_len) :: string + integer :: i, n + + n = lcl_iargc() + call lcl_getarg(0,command_line) + do i = 1, n + call lcl_getarg(i,string) + command_line = trim(command_line)//' '//trim(string) + end do +end function command_line + +!---------------------------------------------------------------------- +!! Return the index of the argument which matches the string opt -- +!! Intended to be used to get hold of the presence of an option, and/or +!! to locate an option so that one can extract values that follow it +!! +!! Trailing spaces are ignored. +!! +!! Returns a negative number if the option is not found. +!! +!! GPS 24/01/98 +!---------------------------------------------------------------------- +function iargc_opt(opt) + use sub_defs_io, except => iargc_opt + use track_args + implicit none + integer :: iargc_opt + character(len=*), intent(in) :: opt + !------------------------------------------------------------ + integer :: i, n + character(len=max_arg_len) :: string + + n = lcl_iargc() + do i = 1, n + call lcl_getarg(i,string) + if (trim(string) == trim(opt)) exit + end do + ! Check to see if argument found + if (i > n) then + !-- make sure that iargc_opt + reasonable number remains negative + iargc_opt = -100 + else + iargc_opt = i + call ta_RegisterUsed(iargc_opt) + end if +end function iargc_opt + + + +!---------------------------------------------------------------------- +!! Return the string value corresponding to the argument which follows +!! the command line option opt +!! +!! GPS 8/11/95 (CCN8 23) +!---------------------------------------------------------------------- +function string_val_opt(opt,default_val) + use sub_defs_io, except => string_val_opt + use track_args + implicit none + character(len=max_arg_len) :: string_val_opt + character(len=*), intent(in) :: opt + character(len=*), intent(in), optional :: default_val + integer :: i,n + i = iargc_opt(opt) + n = lcl_iargc() + if (i >= n .or. i < 0) then + if (present(default_val)) then + string_val_opt = default_val + else + write(0,*) 'String value for option ',trim(opt),' has been& + & requested' + write(0,*) 'but that option is not present, and no default value& + & was provided' + stop + end if + else + call lcl_getarg(i+1,string_val_opt) + call ta_RegisterUsed(i+1) + end if +end function string_val_opt + +!---------------------------------------------------------------------- +!! Return the integer value corresponding to the argument which follows +!! the command line option opt +!! +!! GPS 8/11/95 (CCN8 23) +!---------------------------------------------------------------------- +function int_val_opt(opt,default_val) + use sub_defs_io, except => int_val_opt + implicit none + integer :: int_val_opt + character(len=*), intent(in) :: opt + integer, intent(in), optional :: default_val + !---------------------------------------------------------------------- + integer :: i, n + + i = iargc_opt(opt) + n = lcl_iargc() + if (i >= n .or. i < 0) then + if (present(default_val)) then + int_val_opt = default_val + else + write(0,*) 'Numerical value for option ',trim(opt),' has been& + & requested' + write(0,*) 'but that option is not present, and no default value& + & was provided' + stop + end if + else + int_val_opt = int_val_arg(i+1,default_val) + end if +end function int_val_opt +!---------------------------------------------------------------------- +!! Similar to int_val_opt, but for dble value +!---------------------------------------------------------------------- +function dble_val_opt(opt,default_val) + use sub_defs_io, except => dble_val_opt + implicit none + real(kind(1d0)) :: dble_val_opt + character(len=*), intent(in) :: opt + real(kind(1d0)), intent(in), optional :: default_val + !---------------------------------------------------------------------- + integer :: i, n + + i = iargc_opt(opt) + n = lcl_iargc() + if (i >= n .or. i < 0) then + if (present(default_val)) then + dble_val_opt = default_val + else + write(0,*) 'Numerical value for option ',trim(opt),' has been& + & requested' + write(0,*) 'but that option is not present, and no default value& + & was provided' + stop + end if + else + dble_val_opt = dble_val_arg(i+1,default_val) + end if +end function dble_val_opt +!---------------------------------------------------------------------- +!! Say opt is -xxx: if -xxx is present on the command line, then +!! return true; if -noxxx is present on the command line, then return false. +!! If neither is present on the command line, then return default_val, +!! which therefore is not optional. If both arguments are present, then +!! return default val. +!! +!! GPS 8/11/95 (CCN8 23) +!---------------------------------------------------------------------- +function log_val_opt(opt,default_val) + use sub_defs_io, except => log_val_opt + implicit none + logical :: log_val_opt + character(len=*), intent(in) :: opt + logical, intent(in), optional :: default_val + !---------------------------------------------------------------------- + character(len=30) :: noopt + integer :: i, j + + i = len_trim(opt) + noopt = opt(1:1)//'no'//opt(2:i) + + i = iargc_opt(trim(opt)) + j = iargc_opt(trim(noopt)) + + if (i > 0 .neqv. j > 0) then + log_val_opt = (i>0) + else + if (present(default_val)) then + log_val_opt = default_val + else + log_val_opt = .false. + end if + end if +end function log_val_opt + + +!---------------------------------------------------------------------- +!! Return the integer value corresponding to the argk^th command line +!! argument. If # args < argk then use default if it is present, otherwise +!! output an error message and stop +!! +!! GPS 8/11/95 (CCN8 23) +!---------------------------------------------------------------------- +integer function int_val_arg(argk, default_val) + use track_args + use sub_defs_io, except => int_val_arg + implicit none + integer, intent(in) :: argk + integer, intent(in), optional :: default_val + !------------------------------------------------------------ + integer :: i + character(len=max_arg_len) string + + i = lcl_iargc() + if (i < argk .or. argk < 0) then + if (present(default_val)) then + int_val_arg = default_val + return + else + write(0,*) 'Numerical value of arg',argk,' has been requested' + write(0,*) 'but only',i,' args present, and no default value& + & was provided' + stop + end if + end if + + call lcl_getarg(argk, string) + call ta_RegisterUsed(argk) + if (trim(string) == '-' .and. present(default_val)) then + int_val_arg = default_val + else + int_val_arg = value(string) + end if + +end function int_val_arg + + +!====================================================================== +!! Routine to convert string into an integer +!! Added ability to cope with negative numbers +!! GPS 30/11/94+13/11/96 +!====================================================================== + +integer function value(string) + implicit none + character(*), intent(in) :: string + !---------------------------------------------------------------- + character(11), parameter :: template = '0123456789-' + character :: current + integer :: i, j, sgn + logical :: number_started + + value = 0 + sgn = 1 + number_started = .false. + +loop: do i = 1, len(string) + current = string(i:i) + j = index(template, current) + if (j == 11) then + if (number_started) then + write(0,*) string(1:len(string)), ' is an invalid number' + write(0,*) 'Stop.' + stop + end if + sgn = -1 + number_started = .true. + cycle + end if + if (j /= 0) number_started = .true. + if (number_started) then + if (j == 0) exit + value = value * 10 + (j-1) + endif + end do loop + value = value * sgn +end function value + +!---------------------------------------------------------------------- +!! Return the dble value corresponding to the argk^th command line +!! argument. If # args < argk then use default if it is present, otherwise +!! output an error message and stop +!! +!! GPS 8/11/95 (CCN8 23) +!---------------------------------------------------------------------- +real(kind(1d0)) function dble_val_arg(argk, default_val) + use track_args + use sub_defs_io, except => dble_val_arg + implicit none + integer, intent(in) :: argk + real(kind(1d0)), intent(in), optional :: default_val + !------------------------------------------------------------ + integer :: i + character(80) string + + i = lcl_iargc() + if (i < argk .or. argk < 0) then + if (present(default_val)) then + dble_val_arg = default_val + return + else + write(0,*) 'Numerical value of arg',argk,' has been requested' + write(0,*) 'but only',i,' args present, and no default value& + & was provided' + stop + end if + end if + + call lcl_getarg(argk, string) + call ta_RegisterUsed(argk) + if (trim(string) == '-' .and. present(default_val)) then + dble_val_arg = default_val + else + dble_val_arg = dble_value(string) + end if +end function dble_val_arg + + +!--------------------------------------------------------------- +!! returns the string corresponding to argument argk. +!! If that argument is absent, return the default_val (if provided) +function string_val_arg(argk, default_val) + use track_args + use sub_defs_io, except => string_val_arg + implicit none + character(len=max_arg_len) :: string_val_arg + integer, intent(in) :: argk + character(len=*), intent(in), optional :: default_val + integer :: i + + i = lcl_iargc() + if (i < argk .or. argk < 0) then + if (present(default_val)) then + string_val_arg = trim(default_val) + return + else + write(0,*) 'String value of arg',argk,' has been requested' + write(0,*) 'but only',i,' args present, and no default value& + & was provided' + stop + end if + end if + + call lcl_getarg(argk, string_val_arg) + call ta_RegisterUsed(argk) +end function string_val_arg + + +!====================================================================== +!! Routine to convert string into an float +!! Added ability to cope with negative numbers. Cannot cope with +!! scientific notation or other such fancy things. +!! +!! Actually: current version just does a read on the string... +!! +!! GPS 30/11/94+13/11/96+18/11/96 +!====================================================================== +real(kind(1d0)) function dble_value(string) + implicit none + character(*), intent(in) :: string + !---------------------------------------------------------------- + character(12), parameter :: template = '0123456789-.' + character :: current + integer :: i, j, sgn + logical :: number_started, dpoint + real(kind(1d0)) :: jfact, pfact + + read(string,*) dble_value + return + !-- default sign is positive + sgn = 1 + + number_started = .false. + dpoint = .false. + dble_value = 0 + jfact = 1d0 + pfact = 10d0 + +loop: do i = 1, len(string) + current = string(i:i) + j = index(template, current) + if (j == 11) then + if (number_started) call invalid_number + sgn = -1 + number_started = .true. + cycle + end if + if (j /= 0) number_started = .true. + if (number_started) then + if (j == 0) exit + if (j == 12) then + if (dpoint) call invalid_number + dpoint = .true. + pfact = 1d0 + cycle + end if + if (dpoint) jfact = jfact * 0.1d0 + dble_value = dble_value * pfact + (j-1) * jfact + endif + end do loop + dble_value = dble_value * sgn +contains + + subroutine invalid_number + write(0,*) string(1:len(string)), ' is an invalid number' + write(0,*) 'Stop.' + stop + end subroutine invalid_number + +end function dble_value + +!---------------------------------------------------------------------- +!! A set of routines for converting a number to a string, with optional +!! format specifier. +function int2char(num,frmt) + implicit none + character(len=30) :: int2char + integer, intent(in) :: num + character(*), intent(in), optional :: frmt + if (present(frmt)) then + write(int2char,frmt) num + else + write(int2char,*) num + end if + int2char = adjustl(int2char) +end function int2char +function sp2char(num,frmt) + implicit none + character(len=30) :: sp2char + real(kind(1.0)), intent(in) :: num + character(*), intent(in), optional :: frmt + if (present(frmt)) then + write(sp2char,frmt) num + else + write(sp2char,*) num + end if + sp2char = adjustl(sp2char) +end function sp2char +function dp2char(num,frmt) + implicit none + character(len=30) :: dp2char + real(kind(1d0)), intent(in) :: num + character(*), intent(in), optional :: frmt + if (present(frmt)) then + write(dp2char,frmt) num + else + write(dp2char,*) num + end if + dp2char = adjustl(dp2char) +end function dp2char + + +!====================================================================== +!! Returns a new device if any are available, or else causes an error +!! dump +!! +!! GPS 13/04/98 +!====================================================================== +function get_new_device() result(dev) + use sub_defs_io, except => get_new_device + implicit none + integer :: dev + !-------------------------------------------------------------- + integer, parameter :: dev_low = 30 + logical :: exist, opened + integer :: iostat + character(len=*), parameter :: subname='get_new_device' + + dev = dev_low + do + inquire(unit=dev,iostat=iostat, exist=exist, opened=opened) + if (iostat /= 0) call error_report(subname, 'iostat non zero') + if (.not. exist) call error_report(subname, 'available devices exhausted') + if (.not. opened) exit + dev = dev + 1 + end do + +end function get_new_device + + +!========================================================================== +!! Routine to write `time stamp' to a given output device (idev). The stamp +!! also contains the name of the program that generates it (taken from arg0) +!! +!! GPS 4/12/96 +!========================================================================== +subroutine time_stamp(idev,string) + use sub_defs_io, excepts => time_stamp + implicit none + integer, intent(in), optional :: idev + character(len=*), intent(out), optional :: string + !---------------------------------------------------------------------- + character(79) :: prog_name + integer :: time(8) + + call lcl_getarg(0,prog_name) + call date_and_time(values=time) + if (present(idev)) then + !write(idev,15) prog_name(1:index(prog_name,' ')-1),& + ! & time(3),time(2),time(1),time(5),time(6),time(7) + write(idev,15) trim(prog_name),& + & time(3),time(2),time(1),time(5),time(6),time(7) + end if + if (present(string)) then + !write(string,15) prog_name(1:index(prog_name,' ')-1),& + ! & time(3),time(2),time(1),time(5),time(6),time(7) + write(string,15) trim(prog_name),& + & time(3),time(2),time(1),time(5),time(6),time(7) + end if + +15 format('Stamped by ',a,' on ',i2,'/',i2.2,'/',i4.4,' at ',i2.2,':'& + & ,i2.2 ,':',i2.2) + call lcl_flush(idev) +end subroutine time_stamp + +!====================================================================== +!! Standard error reporting routine. Writes error to +!! stderr and then does one of the following (specified by contents of +!! "action") +!! +!! core +!! stop +!! cont +!! +!! Default action is currently defined below, but maybe its definition +!! should be moved to a globally accessible location. +!! +!! GPS 19/08/97 +!====================================================================== +subroutine error_report(subname,line1,line2,line3,line4,action) + use sub_defs_io, excepts => error_report; implicit none + character(*), intent(in) :: subname + character(*), intent(in), optional :: line1, line2, line3, line4 + character(*), intent(in), optional :: action + !-------------------------------------------------------------------- + character(*), parameter :: default_action = 'core' + character(10) :: laction + real :: a, b + + if (present(action)) then + laction = trim(action) + else + laction = default_action + end if + + write(0,*) + write(0,'(2a)') 'Error report from routine: ',subname + write(0,*) + if (present(line1)) then + write(0,'(a)') 'Reason is:' + write(0,'(a)') line1 + end if + if (present(line2)) write(0,'(a)') line2 + if (present(line3)) write(0,'(a)') line3 + if (present(line4)) write(0,'(a)') line4 + write(0,*) + call time_stamp(0) + !------ allow for more information on exit. + if (trim(laction) == 'core') then + a = 1d0; b = 1d0 + write(0,'(a)') 'Error report routine is about to dump core' + write(0,*) + write(0,*) 1d0/sqrt(a-b) + !-- just in case that did not work, do an explicit stop + stop + else if (trim(laction) /= 'cont') then + write(0,'(a)') 'Program stopped' + stop + else + write(0,'(a)') 'Execution continuing' + end if +end subroutine error_report diff --git a/example_f90/lcl_dec.f90 b/example_f90/lcl_dec.f90 new file mode 100644 index 0000000..8ceaf75 --- /dev/null +++ b/example_f90/lcl_dec.f90 @@ -0,0 +1,115 @@ +!---------------------------------------------------------------------- +! A variety of routines that need to be implementation specific +!---------------------------------------------------------------------- + +!---------------------------------------------------------------------- +! Reading and writing very large 2-dim arrays (with unformatted i/o) causes +! problems on certain systems -- so provide routines which split up +! the reading and writing if that is necessary +! Splitting not required for dec. +!---------------------------------------------------------------------- +subroutine lcl_write_2d(idev, array) + implicit none + integer, intent(in) :: idev + real(kind(1d0)), intent(in) :: array(1:, 1:) + !------------------------------------------------------------ + integer ulim(2), i + + ulim = ubound(array) + do i = 1, ulim(2) + write(idev) real(array(:,i)) + end do + +end subroutine lcl_write_2d + + +subroutine lcl_read_2d(idev, array, ifail) + implicit none + integer, intent(in) :: idev + real(kind(1d0)), intent(out) :: array(1:, 1:) + integer, optional, intent(out) :: ifail + !------------------------------------------------------------ + real, allocatable :: sngl_prec_buffer(:) + integer ulim(2), i!, j + + ulim = ubound(array) + allocate(sngl_prec_buffer(1:ulim(1))) + + do i = 1, ulim(2) + !-- data stored in sngl precision + read(idev, end=10) sngl_prec_buffer(:) + !-- convert it back into double precision + array(:,i) = dble(sngl_prec_buffer(:)) + end do + + !-- correct return code --- + if (present(ifail)) then + ifail = 0 + return + end if + +10 if (present(ifail)) then + ifail = -1 + return + end if +end subroutine lcl_read_2d + +!!$subroutine lcl_write_2d(idev, array) +!!$ implicit none +!!$ integer, intent(in) :: idev +!!$ real, intent(in) :: array(1:, 1:) +!!$ !------------------------------------------------------------ +!!$ +!!$ write(idev) array(:,:) +!!$end subroutine lcl_write_2d +!!$ +!!$ +!!$subroutine lcl_read_2d(idev, array) +!!$ implicit none +!!$ integer, intent(in) :: idev +!!$ real, intent(out) :: array(1:, 1:) +!!$ !------------------------------------------------------------ +!!$ +!!$ read(idev) array(:,:) +!!$end subroutine lcl_read_2d + + + +!---------------------------------------------------------------------- +! Interfaces to the dec f90 iargc and getarg routines +! +! GPS 4/11/95 (CCN8 9) +!---------------------------------------------------------------------- +integer function lcl_iargc() + implicit none + integer iargc + + lcl_iargc = iargc() +end function lcl_iargc + +subroutine lcl_getarg(k, argk) + implicit none + integer, intent(in) :: k + character(*), intent(out) :: argk + + call getarg(k, argk) +end subroutine lcl_getarg + + +subroutine lcl_flush(idev) + implicit none + integer, intent(in) :: idev + + call flush(idev) +end subroutine lcl_flush + +subroutine lcl_system(string) + implicit none + character(*), intent(in) :: string + !------------------------------------------------------------ + !integer return_val, system + + call system(string) +end subroutine lcl_system + + diff --git a/example_f90/mkmk b/example_f90/mkmk new file mode 100755 index 0000000..5a4aea4 --- /dev/null +++ b/example_f90/mkmk @@ -0,0 +1,2 @@ +#!/bin/sh +makePNEW.perl small_fast_tab -lcern -L../src -ldglap -L$LHAPDFDIR -lLHAPDF -I../src diff --git a/example_f90/small_fast_tab.f90 b/example_f90/small_fast_tab.f90 new file mode 100644 index 0000000..2875329 --- /dev/null +++ b/example_f90/small_fast_tab.f90 @@ -0,0 +1,198 @@ + +! on tycho the following combination runs in 4ms per pdf and has +! a relative accuracy (on g,d,u,s) that is typically \lesssim 1e-4, though +! one might want to check the accuracy more systematically. +! +! ./small_fast_tab -nrep 1 -nxQ 500 -output -dy 0.25 -dlnlnQ 0.07 -dt 0.4 -olnlnQ 4 -order 6 -order2 -6 +! +! roughly speaking: evolution takes about 2.5ms and evaluations 1.5ms +! +! Funny thing is that earlier it seemed that runs were much faster +! (factor of two for evolution) and I can't figure out what has +! changed... + +module pdf_initial_condition + use hoppet_v1 + implicit none + +contains + !====================================================================== + !! The dummy PDF suggested by Vogt as the initial condition for the + !! unpolazrized evolution + function unpolarized_dummy_pdf(xvals) result(pdf) + real(dp), intent(in) :: xvals(:) + real(dp) :: pdf(size(xvals),ncompmin:ncompmax) + real(dp) :: uv(size(xvals)), dv(size(xvals)) + real(dp) :: ubar(size(xvals)), dbar(size(xvals)) + !--------------------- + real(dp), parameter :: N_g = 1.7_dp, N_ls = 0.387975_dp + real(dp), parameter :: N_uv=5.107200_dp, N_dv = 3.064320_dp + real(dp), parameter :: N_db = half*N_ls + + pdf = zero + ! clean method for labelling as PDF as being in the human representation + call LabelPdfAsHuman(pdf) + + !-- remember that these are all xvals*q(xvals) + uv = N_uv * xvals**0.8_dp * (1-xvals)**3 + dv = N_dv * xvals**0.8_dp * (1-xvals)**4 + dbar = N_db * xvals**(-0.1_dp) * (1-xvals)**6 + ubar = dbar * (1-xvals) + pdf(:,iflv_g) = N_g * xvals**(-0.1_dp) * (1-xvals)**5 + + pdf(:,-iflv_s) = 0.2_dp*(dbar + ubar) + pdf(:, iflv_s) = pdf(:,-iflv_s) + pdf(:, iflv_u) = uv + ubar + pdf(:,-iflv_u) = ubar + pdf(:, iflv_d) = dv + dbar + pdf(:,-iflv_d) = dbar + end function unpolarized_dummy_pdf + + + subroutine VogtInitSub(y,res) + real(dp), intent(in) :: y + real(dp), intent(out) :: res(ncompmin:) + real(dp) :: x + real(dp) :: uv, dv, ubar, dbar + !--------------------- + real(dp), parameter :: N_g = 1.7_dp, N_ls = 0.387975_dp + real(dp), parameter :: N_uv=5.107200_dp, N_dv = 3.064320_dp + real(dp), parameter :: N_db = half*N_ls + + res = zero + x = exp(-y) + !-- remember that my definitions that these are all x*q(x) + uv = N_uv * x**0.8_dp * (1-x)**3 + dv = N_dv * x**0.8_dp * (1-x)**4 + dbar = N_db * x**(-0.1_dp) * (1-x)**6 + ubar = dbar * (1-x) + res(iflv_g) = N_g * x**(-0.1_dp) * (1-x)**5 + + res(-iflv_s) = 0.2_dp*(dbar + ubar) + res( iflv_s) = res(-iflv_s) + res( iflv_u) = uv + ubar + res(-iflv_u) = ubar + res( iflv_d) = dv + dbar + res(-iflv_d) = dbar + end subroutine VogtInitSub +end module pdf_initial_condition + + +!====================================================================== +program small_fast_tab + use hoppet_v1 + use pdf_initial_condition + use sub_defs_io + implicit none + !------------------------------- + type(grid_def) :: grid, gridarray(3) + type(dglap_holder) :: dh + type(running_coupling) :: coupling + integer :: order, order2, nloop, i, j, nrep, nxQ,nn, olnlnQ + real(dp) :: dy, Qinit, Qmax, y, Q, pdfval(-6:6), dt, dlnlnQ + real(dp) :: ymax + real(dp), pointer :: vogt_init(:,:) + type(pdftab) :: table + logical :: output + + ! set the details of the y=ln1/x grid + dy = dble_val_opt('-dy',0.25_dp) + ymax = dble_val_opt('-ymax',5.0_dp) + order = int_val_opt('-order',5) + order2 = int_val_opt('-order2',order) + if (log_val_opt('-alt')) then + call InitGridDef(gridarray(3),dy/7.0_dp, 1.0_dp, order=order2) + call InitGridDef(gridarray(2),dy/2.0_dp, 3.0_dp, order=order2) + call InitGridDef(gridarray(1),dy, ymax, order=order) + else + call InitGridDef(gridarray(3),dy/9.0_dp, 0.5_dp, order=order2) + call InitGridDef(gridarray(2),dy/3.0_dp, 2.0_dp, order=order2) + call InitGridDef(gridarray(1),dy, ymax, order=order ) + end if + call InitGridDef(grid,gridarray(1:3),locked=.true.) + ! set parameter for evolution step in Q + dt = dble_val_opt('-dt',0.4_dp) + call SetDefaultEvolutionDt(dt) + + ! set up the splitting functions + nloop = int_val_opt('-nloop',3) + if (log_val_opt('-exactth')) & + & call dglap_Set_nnlo_nfthreshold(nnlo_nfthreshold_exact) + if (log_val_opt('-exactsp')) & + & call dglap_Set_nnlo_splitting(nnlo_splitting_exact) + call InitDglapHolder(grid, dh, factscheme=factscheme_MSbar, & + & nloop=nloop, nflo=3, nfhi=6) + + ! first way to get the initial distribution + !call AllocInitPDFSub(grid,vogt_init,VogtInitSub) + ! alternative way to get the initial distribution + call AllocPDF(grid,vogt_init) + vogt_init = unpolarized_dummy_pdf(xValues(grid)) + + ! set up the coupling + Qinit = sqrt(two); Qmax = dble_val_opt('-Qmax',50.0_dp) + call InitRunningCoupling(coupling, alfas=0.35_dp, Q=Qinit, & + &nloop=nloop, use_nah=.true.) + + ! set up the table + dlnlnQ = dble_val_opt('-dlnlnQ',0.07_dp) + olnlnQ = int_val_opt('-olnlnQ',4) + call pdftab_AllocTab(grid,table,Qinit,Qmax,dlnlnQ,lnlnQ_order=olnlnQ) + call pdftab_AssocNfInfo(table,coupling) + call pdftab_PreEvolve(table,Qinit,dh,coupling) + + nrep = int_val_opt('-nrep',1) + nxQ = int_val_opt('-nxQ',0); y = 3.14_dp; Q = 13.354_dp + output = log_val_opt('-output') + if (output) call output_info + + ! output + do i = 1, nrep + call pdftab_InitTabEvolve(table,vogt_init) + + nn = nxQ/3 + do j = 1, nn + y = j*5.0_dp/nn + Q = Qmax - j*(Qmax-Qinit)/nn + call pdftab_ValTab_yQ(table,y,Q,pdfval) + if (output .and. i==1) write(6,'(20es20.8)') y,Q,pdfval(0:3) + !if (output .and. i==1) write(6,'(20es20.8)') y,Q,vogt_init(:,0:3).atx.(grid.with.exp(-y)) + end do + + if (output) write(6,*) + if (output) write(6,*) + do j = nn,1,-1 + y = j*5.0_dp/nn + Q = 4.0_dp + j*5.0_dp/nn + call pdftab_ValTab_yQ(table,y,Q,pdfval) + if (output .and. i==1) write(6,'(20es20.8)') y,Q,pdfval(0:3) + end do + + if (output) write(6,*) + if (output) write(6,*) + do j = nn,1,-1 + y = j*5.0_dp/nn + Q = Qmax*(1-j*0.2_dp/nn) + call pdftab_ValTab_yQ(table,y,Q,pdfval) + if (output .and. i==1) write(6,'(20es20.8)') y,Q,pdfval(0:3) + end do + end do + + ! clean up + call Delete(table) + call Delete(vogt_init) ! here can also use deallocate(vogt_init) + call Delete(dh) + call Delete(coupling) + call Delete(grid) + call Delete(gridarray) + +contains + subroutine output_info + write(6,'(a)') '# '//trim(command_line()) + write(6,'(a,f10.5,a,f10.5)') '# dy = ',dy, '; ymax = ',ymax + write(6,'(a,f10.5,a,f10.5)') '# dt = ',dt, '; Qmax = ',Qmax + write(6,'(a,i5,a,i5)') '# order = ',order, '; order2 = ',order2 + write(6,'(a,f10.5,a,i5)') '# dlnlnQ = ',dlnlnQ, '; olnlnQ = ',olnlnQ + end subroutine output_info + +end program small_fast_tab diff --git a/not-used/OLD-README b/not-used/OLD-README new file mode 100644 index 0000000..761dd9b --- /dev/null +++ b/not-used/OLD-README @@ -0,0 +1,60 @@ + +====================================================================== +---------------------------------------------------------------------- +Manual +------ + +The routines intended to be publicly accessible to the user are to be +found in src/f77_pdf_access.f90. They are as follows + + +subroutine pdfconv_start(dy,nf) + ! this runs the initialisation. + ! dy = internal grid spacing (0.1d0 is a recommended value) + ! nf = number of flavours (5 for most calculations) + + +integer function pdfconv_new_pdf(pdf_subroutine,Q) + ! this returns an integer which is a "handle" to the internally + ! represented pdf. + ! pdf_subroutine: some subroutine with an identical interface + ! to LHAPDF's evolvePDF + ! [i.e. evolvePDF(x,Q,f(-6:6))] + ! Q = Q scale that is passed to pdf_subroutine + + +integer function pdfconv_P_LO(pdf_handle) + ! returns an integer handle to the result of the convolution + ! P_LO \otimes pdf_handle + ! + ! where P_LO is the leading order splitting function matrix with the + ! normalisation such that the LO DGLAP equation is + ! + ! d pdf / dln Q^2 = alphas/2pi * P_LO \otimes pdf + + +integer function pdfconv_P_NLO(pdf_handle) + ! returns an integer handle to the result of the convolution + ! P_NLO \otimes pdf_handle + ! + ! where P_NLO is the NLO splitting function matrix with the + ! normalisation such that the NLO DGLAP equation is + ! + ! d pdf / dln Q^2 = alphas/2pi * P_LO \otimes pdf + ! + (alphas/2pi)^2 * P_NLO \otimes pdf + + +subroutine pdfconv_eval_pdf(handle, x, f) + ! Places in f(-6:6) the quantity x*f(x) for each of the flavours + ! ranging from -6:6 + + +subroutine pdfconv_release_pdf(handle) + ! Declare the PDF referred to via the supplied handle to be no longer + ! needed, allowing the memory to be released back to the system. (It + ! is important to make use of this if you are examining many + ! different PDFs, one after another, otherwise memory consumption + ! will grow to be very large). + + + diff --git a/not-used/f77_pdf_access.f90 b/not-used/f77_pdf_access.f90 new file mode 100644 index 0000000..3ca4cbd --- /dev/null +++ b/not-used/f77_pdf_access.f90 @@ -0,0 +1,166 @@ +!====================================================================== +!! Module containing the locally used information for the f77 pdf acess +!! routines +module f77_pdf_access + use types; use consts_dp + use convolution; use pdf_general; use conv_objects + use holders; use pdf_general + use free_store_pdfs + implicit none + + + type(grid_def), save :: gd, gdarray(3) + type(sigma_holder), save :: sh + + interface + function pdfconv_new_pdf(pdf_subroutine,Q) result(pdf_handle) + use types + implicit none + real(dp), intent(in) :: Q + integer :: pdf_handle + interface + subroutine pdf_subroutine(x,Q,res) + use types; implicit none + real(dp), intent(in) :: x,Q + real(dp), intent(out) :: res(*) + end subroutine pdf_subroutine + end interface + end function pdfconv_new_pdf + end interface + +end module f77_pdf_access + + + +!====================================================================== +!! do all necessary initialisation +subroutine pdfconv_start(dy,nf) + use f77_pdf_access + implicit none + real(dp), intent(in) :: dy + integer, intent(in) :: nf + !------------------------------------- + real(dp) :: ymax + integer :: order + + ! initialise our grids + ymax = 12.0_dp + order = 5 + call conv_InitGridDef(gdarray(3),dy/9.0_dp,0.5_dp, order=order) + call conv_InitGridDef(gdarray(2),dy/3.0_dp,2.0_dp, order=order) + call conv_InitGridDef(gdarray(1),dy, ymax ,order=order) + call conv_InitGridDef(gd,gdarray(1:3),locked=.true.) + + ! initialise the pdf free store + call free_store_pdfs_init + + ! initialise splitting-function holder + call holder_InitSigma(gd,sh,nloop=2,nflo=nf,nfhi=nf) + call holder_SetNf(sh,nf) +end subroutine pdfconv_start + + +!====================================================================== +!! returns an integer handle to the pdf corresponding to calling +!! pdf_subroutine(x,Q,f) at scale Q +function pdfconv_new_pdf(pdf_subroutine,Q) result(pdf_handle) + use f77_pdf_access + implicit none + real(dp), intent(in) :: Q + integer :: pdf_handle + interface + subroutine pdf_subroutine(x,Q,res) + use types; implicit none + real(dp), intent(in) :: x,Q + real(dp), intent(out) :: res(*) + end subroutine pdf_subroutine + end interface + !--------------------------------------------- + real(dp), pointer :: qdist(:,:) + + pdf_handle = new_handle(gd) + call set_pointer_to_pdf(pdf_handle, qdist) + call pdfgen_InitPDF_LHAPDF(gd,qdist,pdf_subroutine,Q) +end function pdfconv_new_pdf + + +!====================================================================== +!! returns a handle (conv_handle) to the result of the convolution +!! +!! P_LO \otimes pdf_handle +!! +!! where P_LO is the leading order splitting function matrix with the +!! normalisation such that the LO DGLAP equation is +!! +!! d pdf / dln Q^2 = alphas/2pi * P_LO \otimes pdf +!! +function pdfconv_P_LO(pdf_handle) result(conv_handle) + use f77_pdf_access + implicit none + integer, intent(in) :: pdf_handle + integer :: conv_handle + !---------------------------------- + real(dp), pointer :: qdist(:,:), conv_qdist(:,:) + + call set_pointer_to_pdf(pdf_handle, qdist) + conv_handle = new_handle(gd) + call set_pointer_to_pdf(conv_handle, conv_qdist) + conv_qdist = sh%P .conv. qdist +end function pdfconv_P_LO + + +!====================================================================== +!! returns a handle (conv_handle) to the result of the convolution +!! +!! P_NLO \otimes pdf_handle +!! +!! where P_NLO is the leading order splitting function matrix with the +!! normalisation such that the NLO DGLAP equation is +!! +!! d pdf / dln Q^2 = alphas/2pi * P_LO \otimes pdf +!! + (alphas/2pi)^2 * P_NLO \otimes pdf +function pdfconv_P_NLO(pdf_handle) result(conv_handle) + use f77_pdf_access + implicit none + integer, intent(in) :: pdf_handle + integer :: conv_handle + !---------------------------------- + real(dp), pointer :: qdist(:,:), conv_qdist(:,:) + + call set_pointer_to_pdf(pdf_handle, qdist) + conv_handle = new_handle(gd) + call set_pointer_to_pdf(conv_handle, conv_qdist) + conv_qdist = sh%P1 .conv. qdist +end function pdfconv_P_NLO + + + +!====================================================================== +!! Places in f(-6:6) the quantity x*f(x) for each of the flavours +!! ranging from -6:6 +subroutine pdfconv_eval_pdf(handle, x, f) + use f77_pdf_access + implicit none + integer, intent(in) :: handle + real(dp), intent(in) :: x + real(dp), intent(out) :: f(-6:6) + !--------------------------------------------- + real(dp), pointer :: qdist(:,:) + + call set_pointer_to_pdf(handle, qdist) + f = qdist .atx. (x.with.gd) +end subroutine pdfconv_eval_pdf + + +!====================================================================== +!! Declare the PDF referred to via the supplied handle to be no longer +!! needed, allowing the memory to be released back to the system. (It +!! is important to make use of this if you are examining many +!! different PDFs, one after another, otherwise memory consumption +!! will grow to be very large). +subroutine pdfconv_release_pdf(handle) + use f77_pdf_access + implicit none + integer, intent(in) :: handle + call release_pdf(handle) +end subroutine pdfconv_release_pdf diff --git a/not-used/free_store_pdfs.f90 b/not-used/free_store_pdfs.f90 new file mode 100644 index 0000000..c56d48e --- /dev/null +++ b/not-used/free_store_pdfs.f90 @@ -0,0 +1,124 @@ +module free_store_pdfs + use types; use consts_dp + use convolution; use pdf_general + use warnings_and_errors + implicit none + private + + type pdf_holder + real(dp), pointer :: pdf(:,:) => null() + end type pdf_holder + ! pointers to the actual pdfs + type(pdf_holder), pointer, save :: pdfs(:) + ! where to look in pdfs to find an available slot + integer , pointer, save :: free_queue(:) + ! where to look in free_queue for next pdf + integer , save :: position_on_queue + + public :: free_store_pdfs_init + public :: new_handle + public :: set_pointer_to_pdf + public :: release_pdf + +contains + + !---------------------------------------------- + !! initialise the free store of pdfs + subroutine free_store_pdfs_init + integer, parameter :: initial_size = 100 + integer :: i + allocate(pdfs(initial_size)) + allocate(free_queue(initial_size)) + forall(i = 1:size(free_queue)) free_queue(i) = i + position_on_queue = 1 + end subroutine free_store_pdfs_init + + !----------------------------------------- + !! return a new pdf handle + integer function new_handle(gd) + type(grid_def), intent(in) :: gd + + if (position_on_queue > size(free_queue)) call resize_free_store + + new_handle = free_queue(position_on_queue) + position_on_queue = position_on_queue + 1 + + call pdfgen_AllocPDF(gd,pdfs(new_handle)%pdf) + end function new_handle + + !-------------------------------------------- + !! Returns a pointer to the pdf... + subroutine set_pointer_to_pdf(handle, pdf) + integer, intent(in) :: handle + real(dp), pointer :: pdf(:,:) + + call validate(handle, 'get_pdf') + pdf => pdfs(handle)%pdf + end subroutine set_pointer_to_pdf + + + + !------------------------------------------- + !! declares the pdf referred to by the handle to be no longer of any + !! use (so memory can be deallocated). + subroutine release_pdf(handle) + integer, intent(in) :: handle + real(dp), pointer :: pdf(:,:) + + call validate(handle, 'release_pdf') + + ! release the memory + deallocate(pdfs(handle)%pdf) + + ! update the free_queue array to indicate that this handle + ! is once again available + position_on_queue = position_on_queue - 1 + free_queue(position_on_queue) = handle + end subroutine release_pdf + + + !------------------------------------------------------------- + !! Increase the size of the free store to allow for extra pdfs + subroutine resize_free_store + type(pdf_holder), pointer :: new_pdfs(:) + integer, pointer :: new_free_queue(:) + integer :: old_size, new_size, i + + old_size = size(pdfs) + new_size = 2*old_size + + ! allocate new arrays + allocate(new_pdfs(new_size)) + allocate(new_free_queue(new_size)) + + ! copy old information on free_queue + get new information + new_free_queue(1:old_size) = free_queue ! maybe not necessary? + forall(i=old_size+1:new_size) new_free_queue(i) = i + + ! copy pointers to pdfs + do i = 1, old_size + new_pdfs(i) = pdfs(i) + end do + + ! deallocate old structures & replace with new + deallocate(pdfs,free_queue) + pdfs => new_pdfs + free_queue => new_free_queue + + end subroutine resize_free_store + + + !-------------------------------------------- + !! check that a handle is legitimate + subroutine validate(handle,source) + integer, intent(in) :: handle + character(len=*), intent(in) :: source + if (handle > 0 .and. handle <= size(pdfs)) then + if (associated(pdfs(handle)%pdf)) return + end if + call wae_error('validate ('//source//')',& + & 'handle value does not correspond to a known pdf',& + & intval = handle) + end subroutine validate + +end module free_store_pdfs diff --git a/scripts/convert.pl b/scripts/convert.pl new file mode 100755 index 0000000..46bb354 --- /dev/null +++ b/scripts/convert.pl @@ -0,0 +1,165 @@ +#!/usr/bin/perl -w +# +# script to convert files from old naming schemes to new ones +# + + +# names that are probably OK, but could do with removal +# of the _conv prefix +@removeconvprefix = ( +"InitGridDef", +"AllocGridQuant", +"InitGridQuant", +"InitGridQuantSub", +"InitGridQuantLHAPDF", +"PrintGridQuant", +"EvalGridQuant", +"MomGridQuant", +"WgtGridQuant", +"AllocGridConv", +"InitGridConv", +"ValidateGD", +"GetDerivedProbes", +"SetDerivedConv", +"SetDerivedConv_nodealloc", +); + +@removepdfgenprefix = ( +"AllocPDF", +"InitPDF", +"InitPDFSub", +"InitPDF_LHAPDF", +"AllocInitPDF", +"AllocInitPDFSub", +); + +# names that need to made more sensible (in convolution.f90) +$rename{qr/conv\\?_DelGridQuant/i} = "Delete"; +$rename{qr/conv\\?_DelGridConv/i} = "Delete"; +$rename{qr/conv\\?_ZeroGridConv/i} = "SetToZero"; +$rename{qr/conv\\?_MultGridConv/i} = "Multiply"; +$rename{qr/conv\\?_AddGridConv/i} = "AddWithCoeff"; +$rename{qr/conv\\?_ConvGridConv/i} = "SetToConvolution"; +$rename{qr/conv\\?_CommGridConv/i} = "SetToCommutator"; +$rename{qr/conv\\?_Seteps/i} = "SetConvolutionEps"; +$rename{qr/SetConvolutionEps/i} = "SetDefaultConvolutionEps"; + + + +# names that need to made more sensible (in conv_objects) +$rename{qr/cobj\\?_InitSplitPolLO/i} = "InitSplitMatPolLO"; +$rename{qr/cobj\\?_InitSplitPolNLO/i} = "InitSplitMatPolNLO"; +$rename{qr/cobj\\?_InitSplitLO/i} = "InitSplitMatLO"; +$rename{qr/cobj\\?_InitSplitNLO/i} = "InitSplitMatNLO"; +$rename{qr/cobj\\?_InitSplitNNLO/i} = "InitSplitMatNNLO"; +$rename{qr/cobj\\?_InitMTMNNLO/i} = "InitMTMNNLO"; + + +# pdf representations +$rename{qr/pdfr\\?_LabelRep/i} = "LabelPdfAsRep"; +$rename{qr/pdfr\\?_GetRep/i} = "GetPdfRep"; +$rename{qr/pdfr_HumanToEvln/i} = "CopyHumanPdfToEvln"; +$rename{qr/pdfr_EvlnToHuman/i} = "CopyEvlnToHumanPdf"; +$rename{qr/CopyEvlnToHumanPdf/i} = "CopyEvlnPdfToHuman";# correct above mistake! + +# conv_objects -> dglap_objects +$rename{qr/cobj\\?_DefaultPrep/i} = "DefaultEvlnRep"; +$rename{qr/conv\\?_objects/i} = "dglap_objects"; +$rename{qr/PMat/i} = "split_mat"; +$rename{qr/CMat/i} = "coeff_mat"; +$rename{qr/MassThresholdMat/i} = "mass_threshold_mat"; +$rename{qr/cobj_InitSplit/i} = "InitSplitMat"; +# things we'll have to sort out partially separately (automated +# name change will deal with calls, but not definition and interface) +$rename{qr/cobj_AddSplit/i} = "AddWithCoeff"; +$rename{qr/cobj_DelSplit/i} = "Delete"; +$rename{qr/cobj_AllocSplit/i} = "AllocSplitMat"; +$rename{qr/cobj_SetNfMTM/i} = "SetNfMTM"; +$rename{qr/cobj\\?_GetDerivedProbes/i} = "GetDerivedSplitMatProbes"; +$rename{qr/cobj_SetDerivedSplit/i}= "SetDerivedSplitMat"; + + +# sigma_holder -> dglap_holder +$rename{qr/holders/i} = "dglap_holders"; +$rename{qr/sigma_holder/i} = "dglap_holder"; +$rename{qr/holder_InitSigma/i} = "InitDglapHolder"; +$rename{qr/holder_SetNf/i} = "SetDglapHolderNf"; +$rename{qr/SetDglapHolderNf/i} = "SetNfDglapHolder"; +$rename{qr/sh/i} = "dh"; +$rename{qr/gd/i} = "grid"; +$rename{qr/dh\%P2/i} = "dh%P_NNLO"; +$rename{qr/dh\%P1/i} = "dh%P_NLO"; +$rename{qr/dh\%P/i} = "dh%P_LO"; + + +# alphas +$rename{qr/as_Del/i} = "Delete"; +$rename{qr/as_server/i} = "qcd_coupling"; +$rename{qr/as_handle/i} = "running_coupling"; +$rename{qr/ash/i} = "coupling"; +$rename{qr/as_Init/i} = "InitRunningCoupling"; +$rename{qr/as_Value/i} = "Value"; +$rename{qr/as_nfRange/i} = "NfRange"; +$rename{qr/as_nfAtQ/i} = "NfAtQ"; +$rename{qr/as_QRangeAtNf/i} = "QRangeAtNf"; + +# evolution +$rename{qr/ev_evolve_varnf/i} = "EvolvePDF"; +$rename{qr/ev_evolve_varnf_gen/i} = "EvolveGeneric"; +$rename{qr/ev_DelEvOp/i} = "Delete"; +$rename{qr/ev\\?_Setdu/i} = "SetDefaultEvolutionDu"; +$rename{qr/ev\\?_Setdt/i} = "SetDefaultEvolutionDt"; + +# pdf tabulation +$rename{qr/pdftab_DelTab/i} = "Delete"; + +# outside access +$rename{qr/pdfevln_all_public/i} = "hoppet_v1"; + +$result = ''; + +if ($#ARGV >= 0) { + open ($filehandle, "<$ARGV[0]") || die "Could not open $ARGV[0] for reading"; +} else { + $filehandle = STDIN; +} + +while ($line=<$filehandle>) { + $result .= $line; +} +close($filehandle); + +$orig_result = $result; + +foreach $name (@removeconvprefix) { + $prefixname = qr/conv\\?_$name/; + $result =~ s/\b$prefixname\b/$name/gi; +} +foreach $name (@removepdfgenprefix) { + $prefixname = qr/pdfgen\\?_$name/; + $result =~ s/\b$prefixname\b/$name/gi; +} + +foreach $name (keys %rename) { + $newname = $rename{$name}; + $result =~ s/\b$name\b/$newname/gi; +} + +# some more delicate cases +$result =~ s/\bid_([a-z]+)\b/iflv_$1/gi; + + +if ($#ARGV >= 0) { + $name = $ARGV[0]; + if ($result eq $orig_result) { + print STDERR "No modifications need be made to $name\n"; + } else { + print STDOUT "Renaming $name to $name.bak\n"; + rename ($name, "$name.bak"); + open (OUT, ">$name") || die "Could not open $name"; + print STDOUT "Writing new version to $name\n"; + print OUT $result; + } +} else { + print $result; +} diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..a3daaae --- /dev/null +++ b/src/Makefile @@ -0,0 +1,113 @@ +# Makefile generated automatically with +# /ada1/lpthe/salam/scripts/makePNEW.perl libdglap.a +# default program to compile +PROG = libdglap.a + +ALLPROG = + +# This will be used one day... +ALLPROGSRC = + +ALLPROGOBJ = + +SRCS = hplog.f xpij2e.f xpns2e.f assertions.f90 coefficient_functions.f90 \ + convolution.f90 dglap_choices.f90 dglap_holders.f90 dglap_objects.f90 \ + evolution.f90 f77_pdftab.f90 hoppet_v1.f90 integrator.f90 \ + interpolation.f90 new_as.f90 pdf_general.f90 pdf_representation.f90 \ + pdf_tabulate.f90 qcd.f90 qcd_coupling.f90 random.f90 runge_kutta.f90 \ + sort.f90 special_functions.f90 splitting_functions.f90 \ + splitting_functions_nnlo.f90 types.f90 warnings_and_errors.f90 \ + welcome_message.f90 xa2hgp.f90 xpij2n.f90 xpij2p.f90 xpns2n.f90 \ + xpns2p.f90 + +POSTSRCS = + +OBJS = hplog.o xpij2e.o xpns2e.o assertions.o coefficient_functions.o \ + convolution.o dglap_choices.o dglap_holders.o dglap_objects.o \ + evolution.o f77_pdftab.o hoppet_v1.o integrator.o interpolation.o \ + new_as.o pdf_general.o pdf_representation.o pdf_tabulate.o qcd.o \ + qcd_coupling.o random.o runge_kutta.o sort.o special_functions.o \ + splitting_functions.o splitting_functions_nnlo.o types.o \ + warnings_and_errors.o welcome_message.o xa2hgp.o xpij2n.o xpij2p.o \ + xpns2n.o xpns2p.o + +POSTOBJS = +POSTLIB = + +LIBS = + +CC = cc +CFLAGS = -O +FC = lf95 +FFLAGS = -O +F90 = lf95 +F90FLAGS = -O +LDFLAGS = + +all: libdglap.a + +libdglap.a: $(OBJS) + ar cru libdglap.a $(OBJS) + ranlib libdglap.a + +ALL: libdglap.a $(ALLPROG) + +libclean: + rm -f $(ALLPROGOBJS) $(OBJS) $(POSTOBJS) + +clean: + rm -f $(ALLPROGOBJS) $(OBJS) $(POSTOBJS) *.mod *.d + +realclean: + rm -f libdglap.a $(ALLPROG) $(ALLPROGOBJ) $(OBJS) $(POSTOBJS) *.mod *.d + +make: + /ada1/lpthe/salam/scripts/makePNEW.perl libdglap.a + +.SUFFIXES: $(SUFFIXES) .f90 + +%.o: %.f90 + $(F90) $(F90FLAGS) -c $< + +xpij2e.o: qcd.o +xpns2e.o: qcd.o +assertions.o: types.o +coefficient_functions.o: convolution.o qcd.o types.o +convolution.o: assertions.o integrator.o interpolation.o sort.o types.o \ + warnings_and_errors.o +dglap_holders.o: assertions.o coefficient_functions.o convolution.o \ + dglap_choices.o dglap_objects.o pdf_representation.o qcd.o types.o \ + warnings_and_errors.o +dglap_objects.o: assertions.o convolution.o dglap_choices.o \ + pdf_representation.o qcd.o splitting_functions.o types.o \ + warnings_and_errors.o +evolution.o: assertions.o convolution.o dglap_choices.o dglap_holders.o \ + dglap_objects.o pdf_representation.o qcd.o qcd_coupling.o \ + runge_kutta.o types.o warnings_and_errors.o +f77_pdftab.o: convolution.o dglap_choices.o dglap_holders.o dglap_objects.o \ + pdf_general.o pdf_tabulate.o types.o warnings_and_errors.o +hoppet_v1.o: convolution.o dglap_choices.o dglap_holders.o dglap_objects.o \ + evolution.o pdf_general.o pdf_representation.o pdf_tabulate.o \ + qcd_coupling.o types.o warnings_and_errors.o +integrator.o: types.o +interpolation.o: types.o warnings_and_errors.o +new_as.o: assertions.o qcd.o runge_kutta.o types.o warnings_and_errors.o +pdf_general.o: convolution.o pdf_representation.o types.o +pdf_representation.o: assertions.o random.o types.o warnings_and_errors.o +pdf_tabulate.o: convolution.o dglap_holders.o dglap_objects.o evolution.o \ + interpolation.o pdf_general.o pdf_representation.o qcd_coupling.o \ + types.o warnings_and_errors.o +qcd.o: types.o +qcd_coupling.o: assertions.o new_as.o types.o warnings_and_errors.o +random.o: types.o +runge_kutta.o: types.o +sort.o: assertions.o types.o warnings_and_errors.o +special_functions.o: types.o +splitting_functions.o: coefficient_functions.o convolution.o qcd.o \ + special_functions.o splitting_functions_nnlo.o types.o \ + warnings_and_errors.o +splitting_functions_nnlo.o: convolution.o dglap_choices.o qcd.o types.o \ + warnings_and_errors.o xpij2e.o xpij2n.o xpij2p.o xpns2e.o xpns2n.o \ + xpns2p.o +types.o: +warnings_and_errors.o: types.o diff --git a/src/assertions.f90 b/src/assertions.f90 new file mode 100644 index 0000000..c07175c --- /dev/null +++ b/src/assertions.f90 @@ -0,0 +1,133 @@ +!====================================================================== +! This contains a few useful bits and pieces, some of which are from NR +! $Id: assertions.f90,v 1.1 2001/06/27 13:40:16 gsalam Exp $ +! +!====================================================================== +module assertions + use types + implicit none + private + + INTERFACE assert_eq + MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eq5,assert_eqn + END INTERFACE + public :: assert_eq + + interface default_or_opt + MODULE PROCEDURE default_or_opt_dp, default_or_opt_sp,& + & default_or_opt_int, default_or_opt_log + end interface + public :: default_or_opt + +contains + + function default_or_opt_dp(xdef,xopt) result(x) + real(dp), intent(in) :: xdef + real(dp), intent(in), optional :: xopt + real(dp) :: x + if (present(xopt)) then + x = xopt + else + x = xdef + end if + end function default_or_opt_dp + function default_or_opt_sp(xdef,xopt) result(x) + real(sp), intent(in) :: xdef + real(sp), intent(in), optional :: xopt + real(sp) :: x + if (present(xopt)) then + x = xopt + else + x = xdef + end if + end function default_or_opt_sp + function default_or_opt_int(xdef,xopt) result(x) + integer, intent(in) :: xdef + integer, intent(in), optional :: xopt + integer :: x + if (present(xopt)) then + x = xopt + else + x = xdef + end if + end function default_or_opt_int + function default_or_opt_log(xdef,xopt) result(x) + logical, intent(in) :: xdef + logical, intent(in), optional :: xopt + logical :: x + if (present(xopt)) then + x = xopt + else + x = xdef + end if + end function default_or_opt_log + + + + + FUNCTION assert_eq2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2 + INTEGER :: assert_eq2 + if (n1 == n2) then + assert_eq2=n1 + else + write (0,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq2' + end if + END FUNCTION assert_eq2 + !BL + FUNCTION assert_eq3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3 + INTEGER :: assert_eq3 + if (n1 == n2 .and. n2 == n3) then + assert_eq3=n1 + else + write (0,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq3' + end if + END FUNCTION assert_eq3 + !BL + FUNCTION assert_eq4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3,n4 + INTEGER :: assert_eq4 + if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then + assert_eq4=n1 + else + write (0,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq4' + end if + END FUNCTION assert_eq4 + FUNCTION assert_eq5(n1,n2,n3,n4,n5,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3,n4,n5 + INTEGER :: assert_eq5 + if (n1 == n2 .and. n2 == n3 .and. n3 == n4 .and. n4 == n5) then + assert_eq5=n1 + else + write (0,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq4' + end if + END FUNCTION assert_eq5 + !BL + FUNCTION assert_eqn(nn,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, DIMENSION(:), INTENT(IN) :: nn + INTEGER :: assert_eqn + if (all(nn(2:) == nn(1))) then + assert_eqn=nn(1) + else + write (0,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eqn' + end if + END FUNCTION assert_eqn + !BL + +end module assertions diff --git a/src/coefficient_functions.f90 b/src/coefficient_functions.f90 new file mode 100644 index 0000000..01e9206 --- /dev/null +++ b/src/coefficient_functions.f90 @@ -0,0 +1,111 @@ +!====================================================================== +! $Id: coefficient_functions.f90,v 1.1 2001/06/27 14:15:16 gsalam Exp $ +module coefficient_functions + use types; use consts_dp; use convolution_communicator + use qcd + implicit none + private + + + public :: cf_CqF2MSbar, cf_CgF2MSbar + public :: cf_CqFL, cf_CgFL + +contains + + function cf_CqF2MSbar(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx + + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x); ln1mx = log(one - x) + res = CF*(two*(ln1mx/(1-x)) - 1.5_dp/(1-x) - (1+x)*ln1mx& + & - (1+x**2)/(1-x)*lnx + 3 + 2*x) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + ln1mx = log(one - x) ! spiacente di farlo due volte + res = res - CF*(two*(ln1mx/(1-x)) - 1.5_dp/(1-x)) + case(cc_DELTA) + res = -CF*(pi**2/3.0_dp + 9.0_dp*half) + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function cf_CqF2MSbar + + + function cf_CgF2MSbar(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx + + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x); ln1mx = log(one - x) + res = TR*(((1-x)**2+x**2)*(ln1mx-lnx)-8*x**2+8*x-1) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function cf_CgF2MSbar + + function cf_CqFL(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = two*CF*x + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function cf_CqFL + + function cf_CgFL(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = four*TR * x*(1-x) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function cf_CgFL + +!. +!. +!. + +end module coefficient_functions diff --git a/src/convolution.f90 b/src/convolution.f90 new file mode 100644 index 0000000..0d7f00f --- /dev/null +++ b/src/convolution.f90 @@ -0,0 +1,2510 @@ +! $Id: convolution.f90,v 1.26 2005/07/08 21:19:17 salam Exp $ + + +!====================================================================== +! Module exlcusively for communication between convolution and +! any routine which might supply convolutions +!====================================================================== +module convolution_communicator + use types + implicit none + private + + integer, public , parameter :: cc_REAL=1,cc_VIRT=2,& + & cc_REALVIRT=3,cc_DELTA =4 + integer, public, save :: cc_piece +end module convolution_communicator + + + +!====================================================================== +! All the base types and routines for happy convolution +! +! Decide on the following policy: grid details will be copied rather +! than pointed to (avoids danger of object that is pointed to being +! changed). Not clear if this is really the best policy, but we will +! give it a try... +! +! GPS 04/04/2000 +!====================================================================== +module convolution + use types; use consts_dp; use assertions; use warnings_and_errors + implicit none + private + + integer, parameter :: conv_UndefinedInt = 1000000004 + + !------------------------------- + ! definition of a grid + ! Includes possibility of one layer of subsiduary definitions + type grid_def + real(dp) :: dy, ymax, eps + integer :: ny, order, nsub + logical :: locked + integer, pointer :: subiy(:) ! starting points of subsiduary grid + type(grid_def), pointer :: subgd(:) ! subsiduary grid defs + end type grid_def + + !-------------------------------------------------- + ! used for abbreviated access to EvalGridQuant + + + type grid_conv + type(grid_def) :: grid + real(dp), pointer :: conv(:,:) => null() + !-- support in construction... + type(grid_conv), pointer :: subgc(:) => null() + end type grid_conv + integer, parameter :: FULL=1, UPPR=2 + !-- for standard linear approach with proper end-point treatment. + ! This must remain zero otherwise inconsistencies will arise + integer, parameter :: LIN_ORDER=0 + + + public :: grid_def, grid_conv + + + !-- public routines -- + interface InitGridDef + module procedure conv_InitGridDef_single, conv_InitGridDef_multi + end interface + public :: conv_InitGridDef_single, conv_InitGridDef_multi + public :: InitGridDef, ValidateGD, GetGridInfoString + public :: SetDefaultConvolutionEps, DefaultConvolutionEps + interface operator(==) + module procedure conv_CmpGridDef + end interface + public :: operator(==) + interface Delete ! made public later... + module procedure Delete_grid_def_0d, Delete_grid_def_1d + end interface + public :: xValues, yValues + + !-- quant routines ----------------------------------------------- + interface AllocGridQuant + module procedure conv_AllocGridQuant_1d,conv_AllocGridQuant_2d,& + & conv_AllocGridQuant_3d + end interface + public :: AllocGridQuant + interface InitGridQuant + module procedure conv_InitGridQuant_func, conv_InitGridQuant_func2d,& + & conv_InitGridQuant_func_a, conv_InitGridQuant_func2d_a,& + & conv_InitGridQuant_func_ai, conv_InitGridQuant_func2d_ai + end interface + ! standard version gives problems with pgf90 5.1-2 (wrong answers)... + interface InitGridQuantSub + module procedure conv_InitGridQuantSub_2d, & + &conv_InitGridQuantSub_2d_a, conv_InitGridQuantSub_2d_ai + end interface + ! This is the workaround suggested by Giulia, across all variants + ! of the subroutine... Testing with pgf90 however shows that we still + ! have the wrong answer (though whether because of this routine + ! or others has not been established). + !interface InitGridQuantSub + ! module procedure conv_InitGridQuantSub_2d_pgf, & + ! &conv_InitGridQuantSub_2d_a_pgf, conv_InitGridQuantSub_2d_ai_pgf + !end interface + + public :: InitGridQuant, InitGridQuantSub, PrintGridQuant + public :: InitGridQuantLHAPDF + interface PrintGridQuant + module procedure conv_PrintGridQuant_1, conv_PrintGridQuant_2,& + & conv_PrintGridQuant_3, conv_PrintGridQuant_4 + end interface + interface EvalGridQuant + module procedure conv_EvalGridQuant_0d, conv_EvalGridQuant_1d + end interface + public :: MomGridQuant, EvalGridQuant, WgtGridQuant + interface Delete + module procedure conv_DelGridQuant_1d, conv_DelGridQuant_2d + module procedure conv_DelGridQuant_3d + end interface + + !public :: Delete + + !-- convolution routines ------------------------------------------- + interface AllocGridConv + module procedure conv_AllocGridConv_0d, conv_AllocGridConv_1d, & + & conv_AllocGridConv_2d + end interface + interface InitGridConv + module procedure conv_InitGridConv_zero, conv_InitGridConv_zero_1d,& + & conv_InitGridConv_zero_2d, conv_InitGridConv_func,& + & conv_InitGridConv_gc, conv_InitGridConv_gc_1d, & + & conv_InitGridConv_gc_2d, conv_InitGridConv_conv + end interface + !-- keep following for historical reasons? Not as of 28/12/01 + !interface conv_GridConvAdd + ! module procedure conv_GridConvAdd_func, conv_GridConvAdd_gc + !end interface + interface SetToZero + module procedure conv_ZeroGridConv_0d, conv_ZeroGridConv_1d,& + & conv_ZeroGridConv_2d + end interface + interface AddWithCoeff + module procedure conv_AddGridConv_func, conv_AddGridConv_gc,& + & conv_AddGridConv_gc_1d, conv_AddGridConv_gc_2d + end interface + interface Multiply + module procedure conv_MultGridConv_0d, conv_MultGridConv_1d, & + & conv_MultGridConv_2d + end interface + interface Delete + module procedure conv_DelGridConv_0d, conv_DelGridConv_1d, & + & conv_DelGridConv_2d + end interface + interface SetToConvolution + module procedure conv_ConvGridConv_0d, conv_ConvGridConv_2dx2d + end interface + interface SetToCommutator + module procedure SetToCommutator_gc + end interface + + + public :: GridConvAllocated + public :: AllocGridConv, InitGridConv, Delete + public :: AddWithCoeff, Multiply, SetToConvolution + public :: SetToZero, SetToCommutator + + !-- REMEMBER: .conv. seems to have a precedence similar to .or., .and. + ! and so is lower precednece than any arithmetic operation + interface operator(.conv.) + module procedure conv_ConvGridQuant_mat, conv_ConvGridQuant_scalar + end interface + public :: operator(.conv.) + !-- put in this version as well because to ease the writing of + ! expressions: * should have the right precedence properties + ! where .conv. seems to have a very low precedence + interface operator(*) + module procedure conv_ConvGridQuant_mat, conv_ConvGridQuant_scalar + end interface + public :: operator(*) + + !-- keep this for historical reasons (hopefully not too long) + interface conv_ConvConv + module procedure conv_InitGridConv_conv + end interface + public :: conv_ConvConv + + !-------------------------- + type gdval + type(grid_def) :: grid + real(dp) :: val + end type gdval + public :: gdval + interface operator(.with.) + module procedure conv_gdval_gdv, conv_gdval_vgd + end interface + public :: operator(.with.) + interface operator(.atx.) + module procedure conv_EvalGridQuant_atx, conv_EvalGridQuant_atx_1d + end interface + public :: operator(.atx.) + interface operator(.aty.) + module procedure conv_EvalGridQuant_aty, conv_EvalGridQuant_aty_1d + end interface + public :: operator(.aty.) + + !-- precision used for integration + real(dp) :: default_conv_eps=1e-7_dp + !real(dp), parameter :: default_conv_eps=1e-8_dp + real(dp), parameter :: warn_tolerance = 1e-3_dp + + !-- used for generation of derived convoluters (e.g. exponentiations + ! of existsing convoluters) + logical :: override_grid_locking = .false. + integer :: nconv_with_override_off = 0 ! + public :: GetDerivedProbes, SetDerivedConv + public :: SetDerivedConv_nodealloc + + ! actual subroutine is to be found in welcome_message.f90 + interface + subroutine HoppetWelcomeMessage + end subroutine HoppetWelcomeMessage + end interface + public :: HoppetWelcomeMessage + +contains + + !====================================================================== + ! Things just for Grid defs. + ! updated for multi. + ! + ! order = 0 -> standard linear + ! order > 0 -> full (order) treatment + ! order < 0 -> treatment correct to |order| except at end points + ! (this is similar to Ratcliffes proposal, hep-ph/0012376) + subroutine conv_InitGridDef_single(grid,dy,ymax,order,eps) + type(grid_def), intent(out) :: grid + real(dp), intent(in) :: dy, ymax + integer, intent(in), optional :: order + real(dp), intent(in), optional :: eps + logical, save :: first_call = .true. + character(len=80) :: string1, string2 + integer, save :: warn_dy = 4 + + if (first_call) then + first_call = .false. + call HoppetWelcomeMessage + end if + + !-- this is a plain grid def --------------------------- + grid%nsub = 0 + nullify(grid%subiy,grid%subgd) + grid%locked = .false. + !------------------------------------------------------- + + grid%ymax = ymax + grid%ny = nint(ymax / dy) + if (grid%ny < 2) then + + write(string1,*) 'InitGridDef: requested too small a number of bins' + write(string2,*) ' dy and ymax were',dy,ymax + call wae_error(trim(string1),trim(string2)) + end if + + grid%dy = ymax / grid%ny + if (abs(grid%dy/dy - one) > 0.001_dp) then + write(string1,*) 'InitGridDef: requested dy of', dy + write(string2,*) ' provided dy of', grid%dy + call wae_warn(warn_dy,trim(string1),trim(string2)) + end if + + if (present(order)) then + !if (order < LIN_ORDER) then + ! write(0,*) 'ERROR in InitGridDef: order < 0& + ! & is not valid in InitGridDef' + ! stop + if (abs(order)+1 > grid%ny) then + call wae_error('InitGridDef: |order|+1 > number of grid points') + end if + grid%order = order + else + grid%order = LIN_ORDER + end if + + grid%eps = default_or_opt(default_conv_eps, eps) + end subroutine conv_InitGridDef_single + + + !-------------------------------------------------------------- + ! Create a multi grid def + subroutine conv_InitGridDef_multi(grid,gdarray,locked) + use sort + type(grid_def), intent(out) :: grid + type(grid_def), intent(in) :: gdarray(:) + logical, intent(in), optional :: locked + !---------------------------------- + integer :: i,j, indx(size(gdarray)) + logical :: used(size(gdarray)) + real(dp) :: dyratio, approx_ny, new_ymax + type(grid_def), pointer :: subgd(:) ! shorthand + ! temp needed for workaround on ifort 8.0.039 + real(dp) :: gdarraydy(size(gdarray)) + character(len=80) :: string1, string2 + integer, save :: warn_locking = 4 + + !-- enforce one layer only + if (any(gdarray(:)%nsub /= 0)) then + call wae_error(& + 'ERROR in conv_InitGridDef_multi:',& + 'One of grid defs in array was a compound grid def.',& + 'Only one layer of compounding is currently allowed.') + end if + + grid%nsub = size(gdarray) + allocate(grid%subiy(grid%nsub+1)) + allocate(grid%subgd(grid%nsub)); subgd => grid%subgd + + grid%locked = default_or_opt(.false.,locked) + if (grid%locked) then + ! this calls gives wrong results with ifort-8.0.039 + ! (dummy array gdarray%dy is corrupted in indexx). Issue + ! submitted 27/01/2004: 225712 + ! "Corrupted answer on call with array of derived type subcomponents" + !call indexx(gdarray%dy, indx) + + ! workaround for ifort-8.0.039 + gdarraydy = gdarray%dy + call indexx(gdarraydy, indx) + do i = 1, grid%nsub + subgd(i) = gdarray(indx(i)) + if (i > 1) then + if (subgd(i)%ymax < subgd(i-1)%ymax) then + write(string1,*) & + &'ERROR in conv_InitGridDef_multi: for locking,' + write(string2,*) 'gdarray with smaller dy should& + & also have smaller gdarray%ymax' + call wae_error(trim(string1), trim(string2)) + ! for testing ifort_8_0_039... + !write(0,*) 'dy values (i-1,i)', subgd(i-1:i)%dy + !write(0,*) 'ymax values (i-1,i)', subgd(i-1:i)%ymax + !write(0,*) indx + !write(0,*) gdarray%dy + !write(0,*) gdarray(indx(:))%dy + !write(0,*) i, subgd(i)%ymax, subgd(i-1)%ymax + !stop + end if + end if + end do + + !-- now ensure that there is proper matching between locked grids + do i = grid%nsub-1, 1, -1 + ! dyratio must be an integer + dyratio = subgd(i+1)%dy / subgd(i)%dy + subgd(i)%dy = subgd(i+1)%dy / nint(dyratio) + if (abs(dyratio-nint(dyratio)) > warn_tolerance*dyratio) then + write(string1,'(a,i2,a,f18.14)') ' InitGridDef (locking):& + & redefined dy(', i,') to be ', subgd(i)%dy + call wae_warn(warn_locking, trim(string1)) + end if + ! after fixing dy one must still have an integer number of bins + approx_ny = subgd(i)%ymax/subgd(i)%dy + subgd(i)%ny = ceiling(approx_ny - warn_tolerance) + new_ymax = subgd(i)%ny * subgd(i)%dy + if (abs(new_ymax-subgd(i)%ymax) > warn_tolerance*new_ymax) then + write(string1,'(a,i2,a,f18.14)') ' InitGridDef (locking):& + & redefined ymax(', i,') to be ', new_ymax + call wae_warn(warn_locking, trim(string1)) + end if + subgd(i)%ymax = new_ymax + subgd(i)%ny = nint(subgd(i)%ymax / subgd(i)%dy) + ! condition on order must still hold + if (abs(subgd(i)%order)+1 > subgd(i)%ny) then + write(string1,'(a)') 'Error in InitGridDef (locking):' + write(string2,'(a,i2,a)') ' For grid def ',i,' |order|+1 > ny' + call wae_error(trim(string1),trim(string2)) + end if + end do + else + !-- no questions asked! + subgd(:) = gdarray(:) + end if + + grid%dy = zero + grid%ymax = maxval(subgd(:)%ymax) + grid%order = conv_UndefinedInt + !-- arrays will stretch from 0:grid%ny; so must get this right! + grid%ny = sum(subgd(:)%ny) + grid%nsub-1 + + !-- indicate starting points of arrays + grid%subiy(1) = 0 + do i = 2, grid%nsub+1 + grid%subiy(i) = grid%subiy(i-1) + subgd(i-1)%ny + 1 + end do + + end subroutine conv_InitGridDef_multi + + + !====================================================================== + !! Set a string with a compact summary about the grid + !! + subroutine GetGridInfoString(grid,string) + use sort + type(grid_def), intent(in) :: grid + character(len=*), intent(out) :: string + !---------------------------------------- + character(len=200) :: my_string ! nice and long! + character(len=200) :: frmt + integer, save :: nwarn_len = 4, nwarn_eps = 4 + integer, allocatable :: indx(:) + + if (grid%nsub == 0) then + write(my_string,& + &'("dy=",f5.3,"|ymax=",f0.2,"|order=",i0,"|eps=",es7.1)') & + & grid%dy,grid%ymax,grid%order,grid%eps + else + allocate(indx(grid%nsub)) + call indexx(-grid%subgd%dy,indx) ! grid%subgd(indx)%dy == decreasing dy + if (any(grid%subgd(2:)%eps /= grid%subgd(1)%eps)) & + &call wae_warn(nwarn_eps,'GetGridInfoString: & + &subgrids have different eps; only largest printed') + if (grid%locked) then + write(frmt,'(a,i0,a,i0,a,i0,a)') & + &'("dy=",f5.3,',grid%nsub-1 ,& + &'("/",i0),"|ymax=",f0.2,',grid%nsub-1,& + &'(":",f0.2),"|order=",sp,i0,',grid%nsub-1,& + &'(":",i0),ss,"|eps=",es7.1)' + write(my_string,trim(frmt)) grid%subgd(indx(1))%dy,& + & nint(grid%subgd(indx(1:grid%nsub-1))%dy/grid%subgd(indx(2:))%dy),& + & grid%subgd(indx)%ymax, grid%subgd(indx)%order,& + & maxval(grid%subgd(:)%eps) + else + write(frmt,'(a,i0,a,i0,a,i0,a)') & + &'("dy=",f5.3,',grid%nsub-1 ,& + &'(":",f5.4),"|ymax=",f0.2,',grid%nsub-1,& + &'(":",f0.2),"|order=",sp,i0,',grid%nsub-1,& + &'ss,(":",i0),"|eps=",es7.1)' + write(my_string,trim(frmt)) grid%subgd(indx(:))%dy,& + & grid%subgd(indx)%ymax, grid%subgd(indx)%order,& + & maxval(grid%subgd(:)%eps) + end if + end if + + if (len_trim(my_string) > len(string)) then + call wae_warn(nwarn_len,& + &"GetGridInfoString: too short a string was passed") + string = my_string(1:len(string)) + else + string = my_string(1:len_trim(my_string)) + end if + + end subroutine GetGridInfoString + + + !====================================================================== + !! Delete the memory associated with a grid definition + recursive subroutine Delete_grid_def_0d(grid) + type(grid_def), intent(inout) :: grid + integer :: isub + + if (grid%nsub /= 0) then + call Delete(grid%subgd(:)) + !do isub = 1, grid%nsub + ! ! following line not strictly needed since (a) we have no more + ! ! than one level of depth and (b) we do not have anything to + ! ! delete in the lowest level. + ! call Delete(grid%subgd(isub)) + !end do + deallocate(grid%subiy) + deallocate(grid%subgd) + end if + + end subroutine Delete_grid_def_0d + + + !====================================================================== + recursive subroutine Delete_grid_def_1d(grid_array) + type(grid_def), intent(inout) :: grid_array(:) + integer :: igrid + do igrid = 1, size(grid_array) + call Delete(grid_array(igrid)) + end do + end subroutine Delete_grid_def_1d + + !====================================================================== + !! Returns .true. iff the two grid definitions are equivalent (i.e. they + !! may be different objects, but correspond to grids with identical + !! parameters). + !! + !! Note that we do not check equality of the value of eps + !! (integration precision) -- whether this is the right choice is + !! arguable, but since it in no way affects interoperability of two + !! grids (e.g. for convolutions between grid_conv objects), it's not + !! too unreasonable. + recursive function conv_CmpGridDef(gd1,gd2) result(equal) + type(grid_def), intent(in) :: gd1, gd2 + logical :: equal + integer :: i + logical, parameter :: verbose = .false. + + if (gd1%nsub /= gd2%nsub) then + equal = .false. + return + else if (gd1%nsub == 0) then + if (verbose) write(0,*) gd1%dy,gd2%dy, gd1%ny, gd2%ny, gd1%ymax,gd2%ymax + equal = (gd1%dy == gd2%dy) .and. (gd1%ny == gd2%ny) .and.& + & (gd1%ymax == gd2%ymax) .and. (gd1%order == gd2%order) + else + equal = .true. + if (.not.associated(gd1%subgd,gd2%subgd)) then + do i = 1, gd1%nsub + equal = equal .and. conv_CmpGridDef(gd1%subgd(i),gd2%subgd(i)) + end do + end if + equal = equal .and. (gd1%locked .eqv. gd2%locked) + end if + end function conv_CmpGridDef + + + !-- useful to be able to check easily ------------------------- + ! no problem with multi + subroutine ValidateGD(gd1,gd2,source) + type(grid_def), intent(in) :: gd1, gd2 + character(len=*), intent(in) :: source + if (.not. (gd1 == gd2)) then + write(0,*) 'Problem validating two grid defs in ',source + stop + end if + end subroutine ValidateGD + + !====================================================================== + !! Return an array containing the y-value of each point on the grid + recursive function yValues(grid) result(res) + type(grid_def), intent(in) :: grid + real(dp) :: res(0:grid%ny) + integer :: iy, isub + + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + res(grid%subiy(isub):grid%subiy(isub+1)-1) = yValues(grid%subgd(isub)) + end do + else + forall(iy=0:grid%ny) res(iy) = iy*grid%dy + end if + end function yValues + + + !====================================================================== + !! Return an array containing the x-value of each point on the grid + function xValues(grid) result(res) + type(grid_def), intent(in) :: grid + real(dp) :: res(0:grid%ny) + + res = exp(-yValues(grid)) + end function xValues + + + !====================================================================== + ! Things just for grid quants + ! multi makes no difference + subroutine conv_AllocGridQuant_1d(grid,gq) + type(grid_def), intent(in) :: grid + real(dp), pointer :: gq(:) + integer :: istat + ! this form of deallocate ought to be OK (?), but on lahey, + ! compaq+condor (and perhaps elsewhere) it causes problems + !deallocate(gq,stat=istat) + allocate(gq(0:grid%ny)) + end subroutine conv_AllocGridQuant_1d + + !---------------------------------------------------------------------- + ! multi makes no difference + subroutine conv_AllocGridQuant_2d(grid,gq,nl,nh) + type(grid_def), intent(in) :: grid + real(dp), pointer :: gq(:,:) + integer, intent(in) :: nl,nh + integer :: istat + ! this form of deallocate ought to be OK (?), but on lahey, + ! compaq+condor (and perhaps elsewhere) it causes problems + !deallocate(gq,stat=istat) + allocate(gq(0:grid%ny,nl:nh)) + end subroutine conv_AllocGridQuant_2d + + !---------------------------------------------------------------------- + ! multi makes no difference + subroutine conv_AllocGridQuant_3d(grid,gq, nl2,nh2, nl3,nh3) + type(grid_def), intent(in) :: grid + real(dp), pointer :: gq(:,:,:) + integer, intent(in) :: nl2,nh2,nl3,nh3 + integer :: istat + ! this form of deallocate ought to be OK (?), but on lahey, + ! compaq+condor (and perhaps elsewhere) it causes problems + !deallocate(gq,stat=istat) + allocate(gq(0:grid%ny,nl2:nh2,nl3:nh3)) + end subroutine conv_AllocGridQuant_3d + + !---------------------------------------------------------- + ! multi makes no difference + subroutine conv_DelGridQuant_1d(gq) + real(dp), pointer :: gq(:) + integer :: istat + deallocate(gq,stat=istat) + end subroutine conv_DelGridQuant_1d + !---------------------------------------------------------- + ! multi makes no difference + subroutine conv_DelGridQuant_2d(gq) + real(dp), pointer :: gq(:,:) + integer :: istat + deallocate(gq,stat=istat) + end subroutine conv_DelGridQuant_2d + !---------------------------------------------------------- + ! multi makes no difference + subroutine conv_DelGridQuant_3d(gq) + real(dp), pointer :: gq(:,:,:) + integer :: istat + deallocate(gq,stat=istat) + end subroutine conv_DelGridQuant_3d + + + + !---------------------------------------------------------------------- + ! updated for multi + recursive subroutine conv_InitGridQuant_func(grid, gq, func) + real(dp), intent(inout) :: gq(0:) + type(grid_def), intent(in) :: grid + interface + function func(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: func + end function func + end interface + !----------------------------------------- + integer :: iy, isub, ny + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuant_func(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1), func) + end do + else + do iy = 0, ny + gq(iy) = func(iy*grid%dy) + end do + end if + + end subroutine conv_InitGridQuant_func + + + !---------------------------------------------------------------------- + ! updated for multi + recursive subroutine conv_InitGridQuant_func_a(grid, gq, func, axtra) + real(dp), intent(inout) :: gq(0:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + interface + function func(x,axtra) + use types; implicit none + real(dp), intent(in) :: x, axtra + real(dp) :: func + end function func + end interface + !----------------------------------------- + integer :: iy, isub, ny + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuant_func_a(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1), func, axtra) + end do + else + do iy = 0, ny + gq(iy) = func(iy*grid%dy, axtra) + end do + end if + + end subroutine conv_InitGridQuant_func_a + + + !---------------------------------------------------------------------- + ! updated for multi + recursive subroutine conv_InitGridQuant_func_ai(grid, gq, func, axtra, ixtra) + real(dp), intent(inout) :: gq(0:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + integer, intent(in) :: ixtra + interface + function func(x,axtra,ixtra) + use types; implicit none + real(dp), intent(in) :: x, axtra + integer, intent(in) :: ixtra + real(dp) :: func + end function func + end interface + !----------------------------------------- + integer :: iy, isub, ny + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuant_func_ai(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1), func, axtra, ixtra) + end do + else + do iy = 0, ny + gq(iy) = func(iy*grid%dy, axtra, ixtra) + end do + end if + + end subroutine conv_InitGridQuant_func_ai + + + !---------------------------------------------------------------------- + ! updated for multi + recursive subroutine conv_InitGridQuant_func2d(grid, gq, func) + real(dp), intent(inout) :: gq(0:,:) + type(grid_def), intent(in) :: grid + interface + function func(x,n) + use types; implicit none + real(dp), intent(in) :: x + integer , intent(in) :: n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + integer :: iy, isub, ny, n + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuant_func2d(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1,:), func) + end do + else + n = ubound(gq, dim=2) + do iy = 0, ny + gq(iy,:) = func(iy*grid%dy, n) + end do + end if + end subroutine conv_InitGridQuant_func2d + + !---------------------------------------------------------------------- + ! version intended for use when there is an extra argument whose + ! value is fixed and needs to be passed to func + ! + ! updated for multi + recursive subroutine conv_InitGridQuant_func2d_a(grid, gq, func, axtra) + real(dp), intent(inout) :: gq(0:,:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + interface + function func(x,axtra,n) + use types; implicit none + real(dp), intent(in) :: x,axtra + integer , intent(in) :: n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + integer :: iy, isub, ny, n + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func2d_a") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuant_func2d_a(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1,:), func, axtra) + end do + else + n = ubound(gq, dim=2) + do iy = 0, ny + gq(iy,:) = func(iy*grid%dy, axtra, n) + end do + end if + end subroutine conv_InitGridQuant_func2d_a + + !---------------------------------------------------------------------- + ! version intended for use when there is an extra argument whose + ! value is fixed and needs to be passed to func + ! + ! updated for multi + recursive subroutine conv_InitGridQuant_func2d_ai(grid, gq, func, axtra, ixtra) + real(dp), intent(inout) :: gq(0:,:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + integer, intent(in) :: ixtra + interface + function func(x,axtra,ixtra,n) + use types; implicit none + real(dp), intent(in) :: x,axtra + integer , intent(in) :: ixtra,n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + integer :: iy, isub, ny, n + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func2d_a") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuant_func2d_ai(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1,:), func, axtra, ixtra) + end do + else + n = ubound(gq, dim=2) + do iy = 0, ny + gq(iy,:) = func(iy*grid%dy, axtra, ixtra, n) + end do + end if + end subroutine conv_InitGridQuant_func2d_ai + + + !---------------------------------------------------------------------- + !! Version added specially for initialising a PDF from a LHAPDF style + !! interface. + recursive subroutine InitGridQuantLHAPDF(grid, gq, LHAsub, Q) + real(dp), intent(inout) :: gq(0:,:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: Q + interface + subroutine LHAsub(x,Q,res) + use types; implicit none + real(dp), intent(in) :: x,Q + real(dp), intent(out) :: res(*) + end subroutine LHAsub + end interface + !----------------------------------------- + integer :: iy, isub, ny + real(dp) :: f(size(gq,dim=2)) + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call InitGridQuantLHAPDF(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1,:), LHAsub, Q) + end do + else + do iy = 0, ny + call LHAsub(exp(-iy*grid%dy), Q, f) + gq(iy,:) = f + end do + end if + end subroutine InitGridQuantLHAPDF + + !---------------------------------------------------------------------- + ! updated for multi + recursive subroutine conv_InitGridQuantSub_2d(grid, gq, sub) + real(dp), intent(inout) :: gq(0:,:) + type(grid_def), intent(in) :: grid + interface + subroutine sub(y,res) + use types; implicit none + real(dp), intent(in) :: y + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + integer :: iy, isub, ny + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuantSub_2d(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1,:), sub) + end do + else + do iy = 0, ny + call sub(iy*grid%dy, gq(iy,:)) + end do + end if + end subroutine conv_InitGridQuantSub_2d + + recursive subroutine conv_InitGridQuantSub_2d_a(grid, gq, sub, axtra) + real(dp), intent(inout) :: gq(0:,:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + interface + subroutine sub(y, axtra, res) + use types; implicit none + real(dp), intent(in) :: y, axtra + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + integer :: iy, isub, ny + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuantSub_2d_a(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1,:), sub, axtra) + end do + else + do iy = 0, ny + call sub(iy*grid%dy, axtra, gq(iy,:)) + end do + end if + end subroutine conv_InitGridQuantSub_2d_a + + recursive subroutine conv_InitGridQuantSub_2d_ai(grid, gq, sub, axtra, ixtra) + real(dp), intent(inout) :: gq(0:,:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + integer, intent(in) :: ixtra + interface + subroutine sub(y, axtra, ixtra, res) + use types; implicit none + real(dp), intent(in) :: y, axtra + integer, intent(in) :: ixtra + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + integer :: iy, isub, ny + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuantSub_2d_ai(grid%subgd(isub), & + &gq(grid%subiy(isub):grid%subiy(isub+1)-1,:), sub, axtra, ixtra) + end do + else + do iy = 0, ny + call sub(iy*grid%dy, axtra, ixtra, gq(iy,:)) + end do + end if + end subroutine conv_InitGridQuantSub_2d_ai + + + !====================================================================== + ! Variants for buggy pgf90-5.1.2, using workaround suggested by + ! Giulia + !---------------------------------------------------------------------- + ! updated for multi + recursive subroutine conv_InitGridQuantSub_2d_pgf(grid, gq, sub) + real(dp), intent(out) :: gq(0:,:) + type(grid_def), intent(in) :: grid + interface + subroutine sub(y,res) + use types; implicit none + real(dp), intent(in) :: y + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + integer :: iy, isub, ny + ! -- GZ:make a copy shifting indices to make it compatible with pgf90 + real(dp) :: gq_cpy(1:size(gq,dim=1),1:size(gq,dim=2)) + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuantSub_2d(grid%subgd(isub), & + &gq_cpy(grid%subiy(isub)+1:grid%subiy(isub+1),:), sub) + end do + else + do iy = 0, ny + call sub(iy*grid%dy, gq_cpy(iy+1,:)) + end do + end if + do iy=0,ny + gq(iy,:) = gq_cpy(iy+1,:) + end do + end subroutine conv_InitGridQuantSub_2d_pgf + + recursive subroutine conv_InitGridQuantSub_2d_a_pgf(grid, gq, sub, axtra) + real(dp), intent(out) :: gq(0:,:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + interface + subroutine sub(y, axtra, res) + use types; implicit none + real(dp), intent(in) :: y, axtra + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + integer :: iy, isub, ny + real(dp) :: gq_cpy(1:size(gq,dim=1),1:size(gq,dim=2)) + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuantSub_2d_a(grid%subgd(isub), & + &gq_cpy(grid%subiy(isub)+1:grid%subiy(isub+1),:), sub, axtra) + end do + else + do iy = 0, ny + call sub(iy*grid%dy, axtra, gq_cpy(iy+1,:)) + end do + end if + do iy=0,ny + gq(iy,:) = gq_cpy(iy+1,:) + end do + end subroutine conv_InitGridQuantSub_2d_a_pgf + + recursive subroutine conv_InitGridQuantSub_2d_ai_pgf(grid, gq, sub, axtra, ixtra) + real(dp), intent(out) :: gq(0:,:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + integer, intent(in) :: ixtra + interface + subroutine sub(y, axtra, ixtra, res) + use types; implicit none + real(dp), intent(in) :: y, axtra + integer, intent(in) :: ixtra + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + integer :: iy, isub, ny + real(dp) :: gq_cpy(1:size(gq,dim=1),1:size(gq,dim=2)) + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"conv_InitGridQuant_func") + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_InitGridQuantSub_2d_ai(grid%subgd(isub), & + &gq_cpy(grid%subiy(isub)+1:grid%subiy(isub+1),:), sub, axtra, ixtra) + end do + else + do iy = 0, ny + call sub(iy*grid%dy, axtra, ixtra, gq_cpy(iy+1,:)) + end do + end if + do iy=0,ny + gq(iy,:) = gq_cpy(iy+1,:) + end do + end subroutine conv_InitGridQuantSub_2d_ai_pgf + + + !-------------------------------------------------------------------- + ! multi-grid done + recursive function conv_EvalGridQuant_0d(grid, gq, y) result(f) + use interpolation + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: gq(0:) + real(dp), intent(in) :: y + real(dp) :: f + !----------------------------------------- + integer, parameter :: npnt_min = 4, npnt_max = 10 + integer :: i, ny, npnt, isub + real(dp) :: ey, df + real(dp), parameter :: resc_yvals(npnt_max) = (/ (i,i=0,npnt_max-1) /) + real(dp) :: wgts(npnt_max) + + !write(0,*) y,grid%ny, ubound(gq,dim=1) + ny = assert_eq(grid%ny,ubound(gq,dim=1),"EvalGridQuant") + if (y > grid%ymax*(one+warn_tolerance)) then + write(0,*) 'EvalGridQuant: & + &requested function value beyond maximum' + write(0,*) 'y = ', y, 'ymax=',grid%ymax + stop + end if + if (grid%nsub /= 0) then + isub = conv_BestIsub(grid,y) + f = EvalGridQuant(grid%subgd(isub), & + & gq(grid%subiy(isub):grid%subiy(isub+1)-1), y) + else + npnt = min(npnt_max, max(npnt_min, abs(grid%order))) + + i = min(max(floor(y / grid%dy)-(npnt-1)/2,0),ny-npnt+1) + call uniform_interpolation_weights(y/grid%dy - i, wgts(1:npnt)) + f = sum(wgts(1:npnt)*gq(i:i+npnt-1)) + !-- this was less efficient... + !call polint(resc_yvals(1:npnt),gq(i:i+npnt-1),y/grid%dy-i,f,df) +!!$ i = min(grid%ny - 1, floor(y / grid%dy)) +!!$ ey = y/grid%dy - i +!!$ f = (one-ey)*gq(i) + ey*gq(i+1) + end if + + end function conv_EvalGridQuant_0d + + !-------------------------------------------------------------------- + !! 1-D version of grid evaluation. + !! + !! NB: we rewrite everything above so as to avoid unnecessary looping. + !! It would be better to have a common routine that gives the + !! required set of points and weights? + recursive function conv_EvalGridQuant_1d(grid, gq, y) result(f) + use interpolation + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: gq(0:,1:) + real(dp), intent(in) :: y + real(dp) :: f(size(gq,dim=2)) + !----------------------------------------- + integer, parameter :: npnt_min = 4, npnt_max = 10 + integer :: i, j, ny, npnt, isub + real(dp) :: ey, df + real(dp), parameter :: resc_yvals(npnt_max) = (/ (i,i=0,npnt_max-1) /) + real(dp) :: wgts(npnt_max) + + !write(0,*) y,grid%ny, ubound(gq,dim=1) + ny = assert_eq(grid%ny,ubound(gq,dim=1),"EvalGridQuant") + if (y > grid%ymax*(one+warn_tolerance)) then + write(0,*) 'EvalGridQuant: & + &requested function value beyond maximum' + write(0,*) 'y = ', y, 'ymax=',grid%ymax + stop + end if + if (grid%nsub /= 0) then + isub = conv_BestIsub(grid,y) + f = conv_EvalGridQuant_1d(grid%subgd(isub), & + & gq(grid%subiy(isub):grid%subiy(isub+1)-1,:), y) + else + npnt = min(npnt_max, max(npnt_min, abs(grid%order))) + + i = min(max(floor(y / grid%dy)-(npnt-1)/2,0),ny-npnt+1) + call uniform_interpolation_weights(y/grid%dy - i, wgts(1:npnt)) + do j = 1, size(f) + f(j) = sum(wgts(1:npnt)*gq(i:i+npnt-1,j)) + end do + + !-- this was less efficient... + !call polint(resc_yvals(1:npnt),gq(i:i+npnt-1),y/grid%dy-i,f,df) +!!$ i = min(grid%ny - 1, floor(y / grid%dy)) +!!$ ey = y/grid%dy - i +!!$ f = (one-ey)*gq(i) + ey*gq(i+1) + end if + end function conv_EvalGridQuant_1d + +!O !-------------------------------------------------------------------- +!O !! 1-D version of grid evaluation. +!O !! +!O !! NB: this is currently VERY slow because interpolation is recalculated +!O !! from scratch for each component of the grid quantity +!O function conv_EvalfGridQuant_1d(grid, gq, y) result(f) +!O type(grid_def), intent(in) :: grid +!O real(dp), intent(in) :: gq(0:,1:) +!O real(dp), intent(in) :: y +!O real(dp) :: f(size(gq,dim=2)) +!O integer :: i +!O do i = 1, size(gq,dim=2) +!O f(i) = conv_EvalGridQuant_0d(grid,gq(:,i),y) +!O end do +!O end function conv_EvalfGridQuant_1d + + + !-------------------------------------------------------------------- + ! Returns starting iymin point and a set of weights in order to calculate + ! the value of the function at y -- one day we might introduce some + ! option of setting the number of points; but not for now... + ! + ! Qu: is the relation between number of points and order correct? It seems + ! like we ought to have abs(grid%order)+1... + recursive subroutine WgtGridQuant(grid, y, iylo, wgts) + use interpolation + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: y + integer, intent(out) :: iylo + real(dp), pointer :: wgts(:) + !----------------------------------------- + integer, parameter :: npnt_min = 4, npnt_max = 10 + integer :: ny, npnt, isub + + ny = grid%ny + if (grid%nsub /= 0) then + isub = conv_BestIsub(grid,y) + call WgtGridQuant(grid%subgd(isub), y, iylo, wgts) + iylo = iylo + grid%subiy(isub) + else + if (y > grid%ymax*(one+warn_tolerance) .or. y < -warn_tolerance) then + write(0,*) 'WgtGridQuant: & + &requested function value outside y range' + write(0,*) 'y = ', y, 'ymax=',grid%ymax + stop + end if + + npnt = min(npnt_max, max(npnt_min, abs(grid%order))) + allocate(wgts(0:npnt-1)) + + iylo = min(max(floor(y / grid%dy)-(npnt-1)/2,0),ny-npnt+1) + call uniform_interpolation_weights(y/grid%dy-iylo, wgts) + end if + end subroutine WgtGridQuant + + + + + !-- for internal use only + function conv_BestIsub(grid,y) result(isub) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: y + integer :: isub + !-- this will probably slow things down, but + ! for the time being accept this penalty + ! find the grid with the smallest ymax > y + if (y>grid%ymax) then + isub = sum(maxloc(grid%subgd%ymax)) + else + isub = sum(minloc(grid%subgd%ymax,mask=(grid%subgd%ymax>=y))) + end if + end function conv_BestIsub + + !---------------------------------------------------------------------- + ! not yet updated for multi-grid purposes, because would require + ! a little bit of thought as to how to treat different grid regions + function MomGridQuant(grid,gq,omega) result(res) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: gq(0:) + real(dp), intent(in) :: omega + real(dp) :: res + !----------------------------------------- + real(dp) :: weight, weightprod, dy + integer :: i, ny + + if (grid%nsub /= 0) then + write(0,*) 'ERROR in MomGridQuant:& + & multiple grids not yet supported' + end if + + ny = assert_eq(grid%ny,ubound(gq,dim=1),"MomGridQuant") + dy = grid%dy + if (omega == zero) then + weight = grid%dy + weightprod = one + res = half*weight*gq(0) + else + weightprod = exp(-dy*omega) + weight = (exp(-dy*omega) - one + dy*omega)/(dy*omega**2) + res = weight*gq(0) + weight = weight + & + & (exp(+dy*omega) - one - dy*omega)/(dy*omega**2) + end if + do i = 1, ny + weight = weight * weightprod + if (i == ny) weight = weight * half + res = res + weight*gq(i) + end do + end function MomGridQuant + + + !---------------------------------------------------------------------- + ! Use a non-sophisticated fix for the multi-grid option, just take the + ! largest of the dy values if none is specified (so as to avoid information + ! overload). + subroutine conv_PrintGridQuant_1(grid,gq,dy,dev) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: gq(0:) + real(dp), intent(in), optional :: dy + integer, intent(in), optional :: dev + real(dp) :: dy_local, y, x, q + integer :: ny, i, dev_local + + ny = assert_eq(grid%ny,ubound(gq,dim=1),'PrintGridQuant') + if (grid%nsub /= 0) then + dy_local = default_or_opt(maxval(grid%subgd%dy),dy) + else + dy_local = default_or_opt(grid%dy,dy) + end if + dev_local = default_or_opt(6,dev) + + ny = floor(grid%ymax / dy_local) + do i = 0, ny + y = i*dy_local + q = EvalGridQuant(grid, gq, y) + write(dev_local,*) y, exp(-y),q + end do + + end subroutine conv_PrintGridQuant_1 + + !---------------------------------------------------------------------- + ! See conv_PrintGridQuant_1 re multigrid + subroutine conv_PrintGridQuant_2(grid,gq,gq2,dy,dev) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: gq(0:),gq2(0:) + real(dp), intent(in), optional :: dy + integer, intent(in), optional :: dev + real(dp) :: dy_local, y, x, q,q2 + integer :: ny, i, dev_local + + ny = assert_eq(grid%ny,ubound(gq,dim=1),& + & ubound(gq2,dim=1),'PrintGridQuant') + if (grid%nsub /= 0) then + dy_local = default_or_opt(maxval(grid%subgd%dy),dy) + else + dy_local = default_or_opt(grid%dy,dy) + end if + dev_local = default_or_opt(6,dev) + + ny = floor(grid%ymax / dy_local) + do i = 0, ny + y = i*dy_local + q = EvalGridQuant(grid, gq, y) + q2 = EvalGridQuant(grid, gq2, y) + write(dev_local,'(25es25.16)') y, exp(-y),q, q2 + end do + + end subroutine conv_PrintGridQuant_2 + + !---------------------------------------------------------------------- + ! See conv_PrintGridQuant_1 re multigrid + subroutine conv_PrintGridQuant_3(grid,gq,gq2,gq3,dy,dev) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: gq(0:),gq2(0:),gq3(0:) + real(dp), intent(in), optional :: dy + integer, intent(in), optional :: dev + real(dp) :: dy_local, y, x, q,q2,q3 + integer :: ny, i, dev_local + + ny = assert_eq(grid%ny,ubound(gq,dim=1),& + & ubound(gq2,dim=1),ubound(gq3,dim=1),& + & 'PrintGridQuant: distributions must be same size') + if (grid%nsub /= 0) then + dy_local = default_or_opt(maxval(grid%subgd%dy),dy) + else + dy_local = default_or_opt(grid%dy,dy) + end if + dev_local = default_or_opt(6,dev) + + ny = floor(grid%ymax / dy_local) + do i = 0, ny + y = i*dy_local + q = EvalGridQuant(grid, gq, y) + q2 = EvalGridQuant(grid, gq2, y) + q3 = EvalGridQuant(grid, gq3, y) + write(dev_local,'(25es25.16)') y, exp(-y),q, q2, q3 + end do + + end subroutine conv_PrintGridQuant_3 + + !---------------------------------------------------------------------- + ! See conv_PrintGridQuant_1 re multigrid + subroutine conv_PrintGridQuant_4(grid,gq,gq2,gq3,gq4,dy,dev) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: gq(0:),gq2(0:),gq3(0:),gq4(0:) + real(dp), intent(in), optional :: dy + integer, intent(in), optional :: dev + real(dp) :: dy_local, y, x, q,q2,q3, q4 + integer :: ny, i, dev_local + + ny = assert_eq(grid%ny,ubound(gq,dim=1),& + & ubound(gq2,dim=1),ubound(gq3,dim=1),ubound(gq4,dim=1),& + & 'PrintGridQuant: distributions must be same size') + if (grid%nsub /= 0) then + dy_local = default_or_opt(maxval(grid%subgd%dy),dy) + else + dy_local = default_or_opt(grid%dy,dy) + end if + dev_local = default_or_opt(6,dev) + + ny = floor(grid%ymax / dy_local) + do i = 0, ny + y = i*dy_local + q = EvalGridQuant(grid, gq, y) + q2 = EvalGridQuant(grid, gq2, y) + q3 = EvalGridQuant(grid, gq3, y) + q4 = EvalGridQuant(grid, gq4, y) + write(dev_local,'(25es25.16)') y, exp(-y),q, q2, q3, q4 + end do + + end subroutine conv_PrintGridQuant_4 + + + !====================================================================== + ! Routines related to convolutions + !====================================================================== + + !---------------------------------------------------------------------- + !! set the default integration precision + subroutine SetDefaultConvolutionEps(eps) + real(dp), intent(in) :: eps + default_conv_eps = eps + end subroutine SetDefaultConvolutionEps + + !---------------------------------------------------------------------- + !! set the default integration precision + real(dp) function DefaultConvolutionEps() result(res) + res = default_conv_eps + end function DefaultConvolutionEps + + + !------------------------------------------------------------------ + ! Just does the memory allocation + recursive subroutine conv_AllocGridConv_0d(grid,gc) + type(grid_def), intent(in) :: grid + type(grid_conv), intent(inout) :: gc + !------------------------------------------- + integer :: isub + + gc%grid = grid + if (gc%grid%nsub /= 0) then + nullify(gc%conv) ! avoid doing anything too stupid... + allocate(gc%subgc(gc%grid%nsub)) + do isub = 1, gc%grid%nsub + call conv_AllocGridConv_0d(grid%subgd(isub),gc%subgc(isub)) + end do + else + nullify(gc%subgc) + ! this form of deallocate ought to be OK (?), but on lahey, + ! compaq+condor (and perhaps elsewhere) it causes problems + !deallocate(gc%conv,stat=istat) + if (grid%order == LIN_ORDER) then + allocate(gc%conv(0:grid%ny,2)) + else if (grid%order > LIN_ORDER) then + allocate(gc%conv(0:grid%ny,0:grid%order+1)) + else + allocate(gc%conv(0:grid%ny,1)) + end if + end if + end subroutine conv_AllocGridConv_0d + + !----------------------------------------------------------------- + ! Handy to have multi-dimensional versions of the above + subroutine conv_AllocGridConv_1d(grid,gc) + type(grid_def), intent(in) :: grid + type(grid_conv), intent(inout) :: gc(:) + !------------------------------------------- + integer :: i + do i = 1, size(gc) + call conv_AllocGridConv_0d(grid,gc(i)) + end do + end subroutine conv_AllocGridConv_1d + subroutine conv_AllocGridConv_2d(grid,gc) + type(grid_def), intent(in) :: grid + type(grid_conv), intent(inout) :: gc(:,:) + !------------------------------------------- + integer :: i,j + do i = 1, size(gc,dim=2) + do j = 1, size(gc,dim=1) + call conv_AllocGridConv_0d(grid,gc(j,i)) + end do + end do + end subroutine conv_AllocGridConv_2d + + + !====================================================================== + !! Return .true. if the gc is currently allocated, .false. otherwise + function GridConvAllocated(gc) + logical :: GridConvAllocated + type(grid_conv), intent(in) :: gc + GridConvAllocated = associated(gc%conv) .or. associated(gc%subgc) + !GridConvAllocated = .false. + end function GridConvAllocated + + !-------------------------------------------------------------------- + ! initialise a grid convolution with zero + ! Default for alloc is .true.; writing this this way allows + ! in principle the possibility of a more levels of recursion + ! in the grid def, should one ever want to have the option... + recursive subroutine conv_InitGridConv_zero(grid,gc,alloc) + type(grid_def), intent(in) :: grid + type(grid_conv), intent(inout) :: gc + logical, intent(in), optional :: alloc + !------------------------------------------- + integer :: isub + + if (default_or_opt(.not.GridConvAllocated(gc),alloc)) then + call AllocGridConv(grid,gc) + else + call ValidateGD(grid, gc%grid, 'conv_InitGridConv_zero') + end if + + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + ! remember not to do double allocate + call conv_InitGridConv_zero(grid%subgd(isub),& + &gc%subgc(isub),alloc=.false.) + end do + else + gc%conv = zero + end if + + end subroutine conv_InitGridConv_zero + + !----------------------------------------------------------------- + ! Handy to have multi-dimensional versions of the above + subroutine conv_InitGridConv_zero_1d(grid,gc,alloc) + type(grid_def), intent(in) :: grid + type(grid_conv), intent(inout) :: gc(:) + logical, intent(in), optional :: alloc + !------------------------------------------- + integer :: i + do i = 1, size(gc) + call conv_InitGridConv_zero(grid,gc(i),alloc) + end do + end subroutine conv_InitGridConv_zero_1d + subroutine conv_InitGridConv_zero_2d(grid,gc,alloc) + type(grid_def), intent(in) :: grid + type(grid_conv), intent(inout) :: gc(:,:) + logical, intent(in), optional :: alloc + !------------------------------------------- + integer :: i,j + do i = 1, size(gc,dim=2) + do j = 1, size(gc,dim=1) + call conv_InitGridConv_zero(grid,gc(j,i),alloc) + end do + end do + end subroutine conv_InitGridConv_zero_2d + + + !-------------------------------------------------------------------- + ! initialise a grid convolution with another gc, potentially multiplied + ! by a factor. Qu: is alloc supposed to be used from outside? + recursive subroutine conv_InitGridConv_gc(gc,gcin,fact,alloc) + type(grid_conv), intent(inout) :: gc + type(grid_conv), intent(in) :: gcin + real(dp), intent(in), optional :: fact + logical, intent(in), optional :: alloc + !------------------------------------------- + integer :: isub + + if (default_or_opt(.not.GridConvAllocated(gc),alloc)) then + call AllocGridConv(gcin%grid,gc) + else + call ValidateGD(gcin%grid,gc%grid,'conv_InitGridConv_gc') + end if + if (gcin%grid%nsub /= 0) then + do isub = 1, gcin%grid%nsub + ! remember not to do double allocate + call conv_InitGridConv_gc(gc%subgc(isub),& + &gcin%subgc(isub),fact=fact,alloc=.false.) + end do + else + if (present(fact)) then + gc%conv = gcin%conv * fact + else + gc%conv = gcin%conv + end if + end if + end subroutine conv_InitGridConv_gc + + !----------------------------------------------------------------- + ! Handy to have multi-dimensional versions of the above + subroutine conv_InitGridConv_gc_1d(gc,gcin,fact,alloc) + type(grid_conv), intent(inout) :: gc(:) + type(grid_conv), intent(in) :: gcin(:) + real(dp), intent(in), optional :: fact + logical, intent(in), optional :: alloc + !------------------------------------------- + integer :: i, ni + ni = assert_eq(size(gc),size(gcin),'conv_InitGridConv_gc_1d') + do i = 1, ni + call conv_InitGridConv_gc(gc(i),gcin(i),fact,alloc) + end do + end subroutine conv_InitGridConv_gc_1d + subroutine conv_InitGridConv_gc_2d(gc,gcin,fact,alloc) + type(grid_conv), intent(inout) :: gc(:,:) + type(grid_conv), intent(in) :: gcin(:,:) + real(dp), intent(in), optional :: fact + logical, intent(in), optional :: alloc + !------------------------------------------- + integer :: i,j,ni,nj + ni = assert_eq(size(gc,dim=2),size(gcin,dim=2),'conv_InitGridConv_gc_1d') + nj = assert_eq(size(gc,dim=1),size(gcin,dim=1),'conv_InitGridConv_gc_1d') + do i = 1, ni + do j = 1, nj + call conv_InitGridConv_gc(gc(j,i),gcin(j,i),fact,alloc) + end do + end do + end subroutine conv_InitGridConv_gc_2d + + + !---------------------------------------------------------------------- + ! Initialise a convoluter with the function to use in the + ! convolution. + subroutine conv_InitGridConv_func(grid,gc,func,alloc) + type(grid_def), intent(in) :: grid + type(grid_conv), intent(inout) :: gc + interface + function func(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: func + end function func + end interface + logical, intent(in), optional :: alloc + !------------------------------------------- + integer :: isub + + !if (default_or_opt(.not.GridConvAllocated(gc),alloc)) call conv_InitGridConv_zero(grid,gc) + call conv_InitGridConv_zero(grid,gc) + + call AddWithCoeff(gc,func) + end subroutine conv_InitGridConv_func + + + !---------------------------------------------------------------------- + ! Initialise a convoluter with the function to use in the + ! convolution. + subroutine conv_InitGridConv_conv(gc,gca,gcb,alloc) + type(grid_conv), intent(inout) :: gc + type(grid_conv), intent(in) :: gca, gcb + logical, intent(in), optional :: alloc + !------------------------------------------- + integer :: isub + + if (default_or_opt(.not.GridConvAllocated(gc),alloc)) then + call AllocGridConv(gca%grid,gc) + else + call ValidateGD(gc%grid, gca%grid,& + & 'conv_InitGridConv_conv: gc and gca') + end if + + call SetToConvolution(gc,gca, gcb) + end subroutine conv_InitGridConv_conv + + !------------------------------------------------------------------ + ! Zero the contents of the grid convolution + ! + recursive subroutine conv_ZeroGridConv_0d(gc) + type(grid_conv), intent(inout) :: gc + integer :: isub + if (gc%grid%nsub /= 0) then + do isub = 1, gc%grid%nsub + call SetToZero(gc%subgc(isub)) + end do + else + gc%conv = zero + end if + end subroutine conv_ZeroGridConv_0d + ! Handy to have multi-dimensional versions of the above + subroutine conv_ZeroGridConv_1d(gc) + type(grid_conv), intent(inout) :: gc(:) + !------------------------------------------- + integer :: i + do i = 1, size(gc) + call conv_ZeroGridConv_0d(gc(i)) + end do + end subroutine conv_ZeroGridConv_1d + subroutine conv_ZeroGridConv_2d(gc) + type(grid_conv), intent(inout) :: gc(:,:) + !------------------------------------------- + integer :: i,j + do i = 1, size(gc,dim=2) + do j = 1, size(gc,dim=1) + call conv_ZeroGridConv_0d(gc(j,i)) + end do + end do + end subroutine conv_ZeroGridConv_2d + + !-------------------------------------------------------- + ! Remove memory associated with a given gc. + recursive subroutine conv_DelGridConv_0d(gc) + type(grid_conv), intent(inout) :: gc + !------------------------------------------- + integer :: istat, isub + + if (.not. GridConvAllocated(gc)) return + + if (gc%grid%nsub /= 0) then + do isub = 1, gc%grid%nsub + call conv_DelGridConv_0d(gc%subgc(isub)) + end do + deallocate(gc%subgc,stat=istat) + nullify(gc%subgc) ! to make sure it isn't left dangling (necessary?) + else + deallocate(gc%conv,stat=istat) + nullify(gc%conv) ! to make sure it isn't left dangling (necessary?) + end if + + if (istat /= 0) then + write(0,*) 'ERROR: problems with deallocation in conv_DelGridConv_0d' + !write(0,*) one/sqrt(sin(zero)) + stop + end if + + end subroutine conv_DelGridConv_0d + !----------------------------------------------------------------- + ! Handy to have multi-dimensional versions of the above + subroutine conv_DelGridConv_1d(gc) + type(grid_conv), intent(inout) :: gc(:) + !------------------------------------------- + integer :: i + do i = 1, size(gc) + call conv_DelGridConv_0d(gc(i)) + end do + end subroutine conv_DelGridConv_1d + subroutine conv_DelGridConv_2d(gc) + type(grid_conv), intent(inout) :: gc(:,:) + !------------------------------------------- + integer :: i,j + do i = 1, size(gc,dim=2) + do j = 1, size(gc,dim=1) + call conv_DelGridConv_0d(gc(j,i)) + end do + end do + end subroutine conv_DelGridConv_2d + + + !-------------------------------------------------------------------- + ! Multiply the given GridConv by the relevant factor + recursive subroutine conv_MultGridConv_0d(gc,fact) + type(grid_conv), intent(inout) :: gc + real(dp), intent(in) :: fact + !------------------------------------------- + integer :: istat, isub + + if (gc%grid%nsub /= 0) then + do isub = 1, gc%grid%nsub + call Multiply(gc%subgc(isub),fact) + end do + else + gc%conv = gc%conv * fact + end if + + end subroutine conv_MultGridConv_0d + !----------------------------------------------------------------- + ! Handy to have multi-dimensional versions of the above + subroutine conv_MultGridConv_1d(gc,fact) + type(grid_conv), intent(inout) :: gc(:) + real(dp), intent(in) :: fact + !------------------------------------------- + integer :: i + do i = 1, size(gc) + call conv_MultGridConv_0d(gc(i),fact) + end do + end subroutine conv_MultGridConv_1d + subroutine conv_MultGridConv_2d(gc,fact) + type(grid_conv), intent(inout) :: gc(:,:) + real(dp), intent(in) :: fact + !------------------------------------------- + integer :: i,j + do i = 1, size(gc,dim=2) + do j = 1, size(gc,dim=1) + call conv_MultGridConv_0d(gc(j,i),fact) + end do + end do + end subroutine conv_MultGridConv_2d + + + + !------------------------------------------------------------- + ! To gc add a function for convolution + recursive subroutine conv_AddGridConv_func(gc,func) + use integrator; use convolution_communicator + type(grid_conv), intent(inout), target :: gc + interface + function func(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: func + end function func + end interface + !---------------------------------------------------- + real(dp), pointer :: dy + integer, pointer :: ny + integer :: order + real(dp) :: upper,lower, yl,ym,yh + integer :: i,j, k + !------------------------------------------------------ + real(dp) :: res,eps!, nodes(gc%grid%order+1) + integer :: inode_one, il, ih, iy, jy, inode + real(dp), allocatable :: nodes(:) + !------------------------------------------------------ + integer :: isub + + if (gc%grid%nsub /= 0) then + do isub = 1, gc%grid%nsub + call conv_AddGridConv_func(gc%subgc(isub),func) + end do + return + end if + + dy => gc%grid%dy + ny => gc%grid%ny + order = gc%grid%order + eps = gc%grid%eps + + !-- this used to be an automatic, but ran into problems + ! with multi-grid splitting functions because compound holder + ! had an undefined value for gc%grid%order + allocate(nodes(abs(gc%grid%order)+1)) + + cc_piece = cc_REAL + if (gc%grid%order == LIN_ORDER) then + do i = 1, ny + ym = i*dy + yl = ym - dy + yh = ym + dy + lower = ig_LinWeight(func,yl,ym,zero,one,eps) ! specify 0 at yl + upper = ig_LinWeight(func,ym,yh,one,zero,eps) ! specify 0 at yh + gc%conv(i,FULL) = gc%conv(i,FULL) + lower + upper + gc%conv(i,UPPR) = gc%conv(i,UPPR) + upper + end do + !-- see CCN17-62 ---- + ym = zero + yh = dy + cc_piece = cc_REAL + upper = ig_LinWeight(func,ym,yh,zero,-one,eps) + cc_piece = cc_REALVIRT + upper = upper + ig_LinWeight(func,ym,yh,one,one,eps) + cc_piece = cc_VIRT + upper = upper + ig_LinWeight(func,yh,-two*log(eps),one,one,eps) + cc_piece = cc_DELTA + upper = upper + func(zero) + gc%conv(0,FULL) = gc%conv(0,FULL) + upper + gc%conv(0,UPPR) = gc%conv(0,UPPR) + upper + else if (gc%grid%order < LIN_ORDER) then + ! should be similar to Ratcliffes proposal (and the sort of thing + ! regularly done in BFKL). NB Not documented in any CCN -- hopefully + ! straightforward enough that it can be done in one's head? + order = -gc%grid%order + do i = 1, ny + !-- this is the range of interest + yl = (i-1) * dy + yh = i * dy + !-- this is range of nodes for that interval + il = i-1 + ih = il + order + nodes = (/ (j,j=il,ih) /) * dy + do iy = il, min(ih,ny) + res = conv_GCAf_Helper(func,yl,yh,il,iy,nodes,eps) + gc%conv(iy,1) = gc%conv(iy,1) + res + end do + end do + !write(0,*) 'conv_AddGridConv_func: Negative orders not yet supported' + !stop + else + !-- CCN19 p.4 ------------- + ! index 0: central points + ! index 1..order+1: for dealing with last order+1 points + !-- first do central points. Do an interval at a time + ! i = 1, means interval from 0 to 1 + !-- the first loop is missing something:: it should also be filling up + ! some pieces in the second loop, at least in some cases + do i = 1, ny + !-- this is the range of interest + yl = (i-1) * dy + yh = i * dy + !-- these are the interpolation points to be used + il = max(0,i - (order+2)/2) + ih = min(ny, il+order) + il = ih - order + !-- fill things up? + nodes = (/ (j,j=il,ih) /) * dy + do iy = il, ih + res = conv_GCAf_Helper(func,yl,yh,il,iy,nodes,eps) + gc%conv(iy,0) = gc%conv(iy,0) + res + !-- deal properly with special end array -- + ! try to be clever with limits, but there are no guarantees. + ! It does however seem to work! + do jy = max(i+order,iy), iy+order + if (jy <= ny) then + gc%conv(jy,order+1-(jy-iy)) & + &= gc%conv(jy,order+1-(jy-iy)) + res + end if + end do + end do + end do + !-- now deal with integrations close to end points + ! k represents the end points + do k = 1, ny + if (k <= order) then + yl = max(zero, (k-order)*dy) + yh = k*dy + !-- the interpolation points & yes, it is normal for them + ! to be negative + ! it is related to the way the convolution is done for the case + ! i < order, i.e. effectively conv(0:order)*gq(order:0:-1) + ! (actually conv(i, 1:order+1)) + ih = k + il = k - order + !-- fill things up + nodes = (/ (j,j=il,ih) /) * dy + do iy = il, ih + res = conv_GCAf_Helper(func,yl,yh,il,iy,nodes,eps) + gc%conv(k,iy-il+1) = gc%conv(k,iy-il+1) + res + end do + cycle + end if + ! now do things region by region + !-- i represents the region that we will study + do i = max(1,k-order+1), k + !-- this is the range of interest + yl = (i-1) * dy + yh = i * dy + !-- these are the interpolation points to be used + ! note extra min(k,...) compared to above formula + il = max(0,i - (order+2)/2) + ih = min(k,min(ny, il+order)) !-- could simplify expression + il = ih - order + nodes = (/ (j,j=il,ih) /) * dy + do iy = max(il,k-order), ih + res = conv_GCAf_Helper(func,yl,yh,il,iy,nodes,eps) + gc%conv(k,order+1-(k-iy)) = & + &gc%conv(k,order+1-(k-iy)) + res + end do + end do + end do + end if + + deallocate(nodes) + + end subroutine conv_AddGridConv_func + + + !--------------------------------------------------------------------- + ! look after some repetitive work... + ! + ! Guess that this function may do the following: + ! Work out the weight corresponding to the integral, between yl and yh + ! of the function func(y) mutiplied by a polynomial which is zero at + ! all the nodes (which start from il) except that indicated by iy. + ! + function conv_GCAf_Helper(func,yl,yh,il,iy,nodes,eps) result(res) + use integrator; use convolution_communicator + interface + function func(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: func + end function func + end interface + real(dp), intent(in) :: yl, yh, nodes(:), eps + integer, intent(in) :: il, iy + real(dp) :: res + integer :: inode + inode = iy - il + 1 + res = zero + if (yl == zero .and. iy == 0) then + cc_piece = cc_VIRT + res = res + ig_LinWeight(func, yh,-two*log(eps), one,one, eps) + cc_piece = cc_DELTA + res = res + func(zero) + cc_piece = cc_REALVIRT + res = res + ig_LinWeight(func, yl, yh, one, one, eps) + cc_piece = cc_REAL + res = res + ig_PolyWeight(func, yl, yh, nodes, inode, eps,wgtadd=-one) + else + cc_piece = cc_REAL + res = ig_PolyWeight(func, yl, yh, nodes, inode, eps) + end if + end function conv_GCAf_Helper + + + + !------------------------------------------------------------- + ! To gc add another grid convolution. + ! + ! Perhaps there are some inefficiences here (validation may sometimes + ! be carried out twice), but for the time being, leave it as is. + recursive subroutine conv_AddGridConv_gc(gc,gcadd,fact) + type(grid_conv), intent(inout) :: gc + type(grid_conv), intent(in) :: gcadd + real(dp), intent(in), optional :: fact + !---------------------------------------------- + integer :: isub + + call ValidateGD(gc%grid, gcadd%grid, 'conv_AddGridConv_gc') + if (gc%grid%nsub /= 0) then + do isub = 1, gc%grid%nsub + call conv_AddGridConv_gc(gc%subgc(isub),gcadd%subgc(isub),fact) + end do + else + if (present(fact)) then + gc%conv = gc%conv + gcadd%conv * fact + else + gc%conv = gc%conv + gcadd%conv + end if + end if + + end subroutine conv_AddGridConv_gc + !----------------------------------------------------------------- + ! Handy to have multi-dimensional versions of the above + subroutine conv_AddGridConv_gc_1d(gc,gcadd,fact) + type(grid_conv), intent(inout) :: gc(:) + type(grid_conv), intent(in) :: gcadd(:) + real(dp), intent(in), optional :: fact + !------------------------------------------- + integer :: i + do i = 1, size(gc) + call conv_AddGridConv_gc(gc(i),gcadd(i),fact) + end do + end subroutine conv_AddGridConv_gc_1d + subroutine conv_AddGridConv_gc_2d(gc,gcadd,fact) + type(grid_conv), intent(inout) :: gc(:,:) + type(grid_conv), intent(in) :: gcadd(:,:) + real(dp), intent(in), optional :: fact + !------------------------------------------- + integer :: i,j + do i = 1, size(gc,dim=2) + do j = 1, size(gc,dim=1) + call conv_AddGridConv_gc(gc(j,i),gcadd(j,i),fact) + end do + end do + end subroutine conv_AddGridConv_gc_2d + + + !-------------------------------------------------------------- + ! Carry out the convolution of gc on gq + recursive function conv_ConvGridQuant_scalar(gc,gq) result(gqout) + type(grid_conv), intent(in),target :: gc + real(dp), intent(in) :: gq(0:) + real(dp) :: gqout(0:ubound(gq,dim=1)) + !--------------------------------------------- + integer :: i, ny, j + integer :: order + integer :: isub, iy, dy_ratio + + if (gc%grid%nsub /= 0) then + do isub = 1, gc%grid%nsub + gqout(gc%grid%subiy(isub):gc%grid%subiy(isub+1)-1) = & + & conv_ConvGridQuant_scalar(gc%subgc(isub),& + & gq(gc%grid%subiy(isub):gc%grid%subiy(isub+1)-1)) + end do + + if (gc%grid%locked .and. .not.override_grid_locking) then + !-- decant information from finer grids into coarser grids + ! (remember: finest grid has lowest isub) + do isub = 2, gc%grid%nsub + ! the ratio should be an exact integer, but use + ! nint() to avoid the dangers of rounding errors + dy_ratio = nint(gc%grid%subgd(isub)%dy / gc%grid%subgd(isub-1)%dy) + do iy = 0, gc%grid%subgd(isub-1)%ny / dy_ratio + gqout(gc%grid%subiy(isub)+iy) = & + &gqout(gc%grid%subiy(isub-1)+iy*dy_ratio) + end do + end do + nconv_with_override_off = nconv_with_override_off + 1 + end if + return + end if + + ny = assert_eq(gc%grid%ny,ubound(gq,dim=1),"conv_ConvGridQuant") + order = gc%grid%order + + !-- Hopefully this will avoid some wasted convolutions? + if (all(gq == zero)) then + gqout = zero + return + end if + + + if (order == LIN_ORDER) then + !-- a test to avoid N^2 operations... + if (all(gc%conv(:,FULL) == zero)) then + gqout = zero + return + end if + + gqout(0) = zero + do i = 1, ny + !-- following is legal fortran but it is very slow sometimes + gqout(i) = sum(gq(0:i)*gc%conv(i:0:-1,FULL)) + !-- maybe the version that follows will be faster on some compilers + ! on absoft it definitely is +!!$ gqout(i) = zero +!!$ do j = 0, i +!!$ gqout(i) = gqout(i) + gq(j)*gc%conv(i-j,FULL) +!!$ end do + !write(0,*) i*gc%grid%dy,gqout(i), gc%conva(1) + gqout(i) = (gqout(i)-gq(0)*gc%conv(i,UPPR)) + end do + else if (order < 0) then + ! Ratcliffes proposal + !gqout(0) = zero + ! NB: explicitly do also the i=0 case. Under normal circumstances + ! it should give zero; however we still let the user enjoy + ! their folly if they really want to have gq(0)/=0 --- this + ! is something that comes in handy when generating "derived" + ! convolutors... + do i = 0, ny + gqout(i) = sum(gc%conv(0:i,1)*gq(i:0:-1)) + end do + else + gqout = zero + !-- a test to avoid N^2 operations... + if (all(gc%conv(:,0) == zero)) return + !-- current writing is designed to reduce thrashing of cache. + ! It is not clear that it actually helps in any way + ! Commented version theoretically has higher cache thrashing. + do i = 1, ny + if (i > order) then + gqout(i) = sum(gc%conv(0:i-order-1,0)*gq(i:order+1:-1)) + end if + !-- HIGH CACHE THRASH + !gqout(i) = gqout(i) + sum(gc%conv(i,1:order+1)*gq(order:0:-1)) + end do + !-- LOW CACHE THRASH + do i = 1, order+1 + gqout(:) = gqout(:) + gc%conv(:,i)*gq(order+1-i) + end do + end if + + end function conv_ConvGridQuant_scalar + + + + !-------------------------------------------------------------- + ! Carry out the convolution of two convolution functions + ! It is recommended that if one of them is singular at x=1, then this be + ! gca: this helps minimise the discretisation error (in some cases). + ! + ! NB: subroutine name is not quite consistent with things like + ! Add or Mult since the operands are completely distinct from the + ! result. + recursive subroutine conv_ConvGridConv_0d(gc,gca, gcb, reorder) + type(grid_conv), intent(inout) :: gc + type(grid_conv), intent(in), target :: gca, gcb + logical, intent(in), optional :: reorder + !--------------------------------------------- + type(grid_conv), pointer :: gcap, gcbp + integer :: i, ny, j, order, ix + !-- these might be better if on the fly, given recursive nature? + real(dp) :: deltafn(0:gca%grid%ny), res(0:gca%grid%ny) + integer :: isub + + call ValidateGD(gca%grid, gcb%grid, 'conv_ConvGridConv_0d: gca and gcb') + if (.not.GridConvAllocated(gc)) then + call AllocGridConv(gca%grid,gc) + else + call ValidateGD(gc%grid, gca%grid, 'conv_ConvGridConv_0d: gc and gca') + end if + + if (gc%grid%nsub /= 0) then + do isub = 1, gc%grid%nsub + call conv_ConvGridConv_0d(gc%subgc(isub),& + & gca%subgc(isub), gcb%subgc(isub),reorder) + end do + return + end if + + if (default_or_opt(.true.,reorder)) then + !-- decide which part of conv matrix to use + select case (gca%grid%order) + case(LIN_ORDER) + ix = FULL + case(LIN_ORDER+1:) + ix = 0 + case(:LIN_ORDER-1) + ix = 1 + end select + + !-- use as only criterion of singularity that there should be + ! opposite signs for the first two grid points? This is not + ! by any means foolproof, but in basic cases it seems to work. + ! Put the less singular convolutor to the right. + if (product(gca%conv(0:1,ix)) >= zero .and. & + & product(gcb%conv(0:1,ix)) < zero) then + call conv_ConvGridConv_0d(gc,gcb, gca, reorder=.false.) + return + end if + end if + + + if (gca%grid%order == LIN_ORDER) then + !-- this is just a guess. Now we will see if it is right + gc%conv(:,FULL) = (gca .conv. gcb%conv(:,FULL)) +& + &gca%conv(:,UPPR) * gcb%conv(0,FULL) + + !-- next 3 lines actually calculate LOWER. Then correct it to upper. + ! Do the convolution of a deltafn by hand in order to + ! be more efficient: tested that it gave identical answers + deltafn = gcb%conv(:,FULL) - gcb%conv(:,UPPR) + deltafn(0) = zero + gc%conv(:,UPPR) = gca .conv. deltafn + !gc%conv(:,UPPR) = gca .conv. (gcb .conv. deltafn) + gc%conv(:,UPPR) = gc%conv(:,FULL) - gc%conv(:,UPPR) + else if (gca%grid%order < LIN_ORDER) then + ! the ratcliffe approach + do i = 0, gc%grid%ny + gc%conv(i,1) = sum(gca%conv(0:i,1)*gcb%conv(i:0:-1,1)) + end do + !write(0,*) 'SetToConvolution: Negative orders not yet supported' + !stop + else + order = gca%grid%order + !-- let us hope that the following works? + ! in this first incarnation it will be roughly half the optimum + ! speed because the inner convolution will be done "stupidly", + ! using O(N^2) steps rather than the possible O(N) + do j = 0, order+1 + !-- set up a delta function and its convolution + deltafn = zero; deltafn(j) = one + !-- try to avoid too much rubbish in the result? + res = zero + res = gca .conv. (gcb .conv. deltafn) + !-- redistribute the result + if (j /= order+1) then + gc%conv(:,order+1-j) = res(:) + else + gc%conv(0:gca%grid%ny-(order+1),0) = res(order+1:gca%grid%ny) + !-- The region conv(gca%grid%ny-order:) remains unfilled. This + ! is OK since in practice (current incarnation) it never + ! gets used. + end if + end do + !-- now remember to test it! + end if + + + end subroutine conv_ConvGridConv_0d + + !-------------------------------------------------------------------- + ! version for automatically doing convolution of two 2x2 arrays + ! with array multiplication in the usual fortran sense + subroutine conv_ConvGridConv_2dx2d(gc,gca, gcb) + type(grid_conv), intent(inout) :: gc(:,:) + type(grid_conv), intent(in) :: gca(:,:), gcb(:,:) + !---------------------------------------------------- + integer :: ir, im, ic, nr, nm, nc + type(grid_conv) :: conv + + nr = assert_eq(size(gc,dim=1),size(gca,dim=1) ,'conv_ConvGridConv_2dx2d') + nc = assert_eq(size(gc,dim=2),size(gcb,dim=2) ,'conv_ConvGridConv_2dx2d') + nm = assert_eq(size(gca,dim=2),size(gcb,dim=1),'conv_ConvGridConv_2dx2d') + + ! allocate gc if need be, with default initialization of zero + call InitGridConv(gca(1,1)%grid, gc) + !call SetToZero(gc) + + call AllocGridConv(gc(1,1)%grid,conv) + do ic = 1, nc + do ir = 1, nr + do im = 1, nm + call conv_ConvGridConv_0d(conv,gca(ir,im),gcb(im,ic)) + call AddWithCoeff(gc(ir,ic),conv) + end do + end do + end do + call Delete(conv) + + end subroutine conv_ConvGridConv_2dx2d + + !-------------------------------------------------------------------------- + ! Returns in gc (assumed preallocated) the commutator of + ! gca and gcb. Does nothing clever about ordering of + ! the arrays... + ! + ! This is a very inefficient version because it does many more convolutions + ! than are needed. Only for 2x2 arrays does it do a reasonably sensible job. + ! + subroutine SetToCommutator_gc(gc,gca, gcb) + type(grid_conv), intent(inout) :: gc(:,:) + type(grid_conv), intent(in) :: gca(:,:), gcb(:,:) + !---------------------------------------------------- + type(grid_conv) :: cc(size(gc,dim=1),size(gc,dim=2)) + type(grid_conv) :: prod + + ! allocate gc if need be, with default initialization of zero + call InitGridConv(gca(1,1)%grid, gc) + !call SetToZero(gc) + + ! allocate some more memory + call AllocGridConv(gc(1,1)%grid,cc) + + !-- use a shortcut for 2-dim arrays; do things long-hand + ! for others + if (size(gc,dim=1) == 2 .and. size(gc,dim=2) == 2) then + !-- for 2x2 arrays we will want to do something along the following lines + ! (with a similar definition for B). +!> A:=matrix(2,2,[a11,a12,a21,a22]); +! [a11 a12] +! A := [ ] +! [a21 a22] +!----------------------------------------------------------------------- +!> matadd(multiply(A,B),-multiply(B,A)); +! [ a12 b21 - a21 b12 a11 b12 + a12 b22 - b11 a12 - b12 a22] +! [ ] +! [a21 b11 + a22 b21 - b21 a11 - b22 a21 a21 b12 - a12 b21 ] + call AllocGridConv(gc(1,1)%grid,prod) + + ! res11 = a12 b21 - a21 b12 + call SetToConvolution(prod,gca(1,2),gcb(2,1)) + call AddWithCoeff(gc(1,1),prod) + call SetToConvolution(prod,gca(2,1),gcb(1,2)) + call AddWithCoeff(gc(1,1),prod,-one) + ! res22 = -res 11 + call AddWithCoeff(gc(2,2),gc(1,1),-one) + ! res12 = a11 b12 + a12 b22 - b11 a12 - b12 a22 + call SetToConvolution(prod,gca(1,1),gcb(1,2)) + call AddWithCoeff(gc(1,2),prod) + call SetToConvolution(prod,gca(1,2),gcb(2,2)) + call AddWithCoeff(gc(1,2),prod) + call SetToConvolution(prod,gca(1,2),gcb(1,1)) + call AddWithCoeff(gc(1,2),prod,-one) + call SetToConvolution(prod,gca(2,2),gcb(1,2)) + call AddWithCoeff(gc(1,2),prod,-one) + ! res21 = a21 b11 + a22 b21 - b21 a11 - b22 a21 + call SetToConvolution(prod,gca(2,1),gcb(1,1)) + call AddWithCoeff(gc(2,1),prod) + call SetToConvolution(prod,gca(2,2),gcb(2,1)) + call AddWithCoeff(gc(2,1),prod) + call SetToConvolution(prod,gca(1,1),gcb(2,1)) + call AddWithCoeff(gc(2,1),prod,-one) + call SetToConvolution(prod,gca(2,1),gcb(2,2)) + call AddWithCoeff(gc(2,1),prod,-one) + + call Delete(prod) + else + call SetToConvolution(cc,gca,gcb) + call AddWithCoeff(gc,cc) + call SetToConvolution(cc,gcb,gca) + call AddWithCoeff(gc,cc,-one) + end if + + call Delete(cc) + end subroutine SetToCommutator_gc + + + + !-------------------------------------------------------------- + ! Carry out the convolution of gc on gq: but not always the + ! most efficient way of dealing with the problem... + function conv_ConvGridQuant_mat(gc,gq) result(gqout) + type(grid_conv), intent(in) :: gc(:,:) + real(dp), intent(in) :: gq(0:,:) + real(dp) :: gqout(0:ubound(gq,dim=1),size(gc,dim=1)) + !--------------------------------------------- + integer :: i, ny, ic, ir, ncol, nrow + + ny = assert_eq(gc(1,1)%grid%ny,ubound(gq,dim=1),"conv_ConvGridQuant") + ncol = assert_eq(size(gc,dim=2),size(gq,dim=2),"conv_ConvGridQuant") + nrow = size(gc,dim=1) + + gqout = zero + do ir = 1, nrow + do ic = 1, ncol + !gqout(:,ir) = gqout(:,ir) + gc(ir,ic) .conv. gq(:,ic) + gqout(:,ir) = gqout(:,ir) +& + & conv_ConvGridQuant_scalar(gc(ir,ic), gq(:,ic)) + end do + end do + end function conv_ConvGridQuant_mat + + + + !====================================================================== + ! things for easier access to a given grid point + ! (but may not be as fast as just calling the routine) + function conv_gdval_gdv(grid,val) result(gdv) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: val + type(gdval) :: gdv + gdv%grid = grid + gdv%val = val + end function conv_gdval_gdv + function conv_gdval_vgd(val,grid) result(gdv) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: val + type(gdval) :: gdv + gdv%grid = grid + gdv%val = val + end function conv_gdval_vgd + function conv_EvalGridQuant_atx(gq, gdv) result(res) + real(dp), intent(in) :: gq(:) + type(gdval), intent(in) :: gdv + real(dp) :: res + res = EvalGridQuant(gdv%grid, gq, -log(gdv%val)) + end function conv_EvalGridQuant_atx + function conv_EvalGridQuant_atx_1d(gq, gdv) result(res) + real(dp), intent(in) :: gq(:,:) + type(gdval), intent(in) :: gdv + real(dp) :: res(size(gq,dim=2)) + res = EvalGridQuant(gdv%grid, gq, -log(gdv%val)) + end function conv_EvalGridQuant_atx_1d + function conv_EvalGridQuant_aty(gq, gdv) result(res) + real(dp), intent(in) :: gq(:) + type(gdval), intent(in) :: gdv + real(dp) :: res + res = EvalGridQuant(gdv%grid, gq, gdv%val) + end function conv_EvalGridQuant_aty + function conv_EvalGridQuant_aty_1d(gq, gdv) result(res) + real(dp), intent(in) :: gq(:,:) + type(gdval), intent(in) :: gdv + real(dp) :: res(size(gq,dim=2)) + res = EvalGridQuant(gdv%grid, gq, gdv%val) + end function conv_EvalGridQuant_aty_1d + + + !====================================================================== + ! Routines for getting derived convolution operators + ! + ! See also notes on CCN25-96 + !====================================================================== + ! Allocates and returns an array of probes, each of which must + ! be operated on with the convolver, after which the user should + ! call SetDerivedConv, which formalises the results + subroutine GetDerivedProbes(grid,probes) + type(grid_def), intent(in) :: grid + real(dp), pointer :: probes(:,:) + !--------------------- + integer :: nprobes + + nprobes = 0 + call conv_GetNProbes(grid,nprobes) + call AllocGridQuant(grid,probes,1,nprobes) + call conv_SetProbes(grid,probes) + + ! safety measures -- this is a NASTY business, but cannot + ! thing of another way to ensure & check that grid locking is + ! off... + override_grid_locking = .true. + nconv_with_override_off = 0 + end subroutine GetDerivedProbes + + !---------------------------------------------------------------------- + ! Sets up the "derived" convolution operator. + ! + ! This routine actually just does the housekeeping -- the actual "hard" + ! work is done by conv_SetDerivedConv_rec + ! + ! NB: gc must previously have been allocated + subroutine SetDerivedConv(gc,probes) + real(dp), pointer :: probes(:,:) + type(grid_conv), intent(inout) :: gc + + call SetDerivedConv_nodealloc(gc,probes) + deallocate(probes) + end subroutine SetDerivedConv + + !---------------------------------------------------------------------- + ! runs through each of the elements of grid and establishes + ! the number of probes needed. Currently only supports cases + ! in which there is just a single probe... + recursive subroutine conv_GetNProbes(grid,nprobes) + use warnings_and_errors + type(grid_def), intent(in) :: grid + integer, intent(out) :: nprobes + !--------- + integer :: nprobes_tmp, isub + if (grid%nsub /= 0) then + nprobes = 0 + do isub = 1, grid%nsub + call conv_GetNProbes(grid%subgd(isub),nprobes_tmp) + nprobes = max(nprobes, nprobes_tmp) + end do + else + select case(grid%order) + case(:LIN_ORDER-1) + nprobes = 1 + case(LIN_ORDER) + nprobes = 2 + case(LIN_ORDER+1:) + nprobes = grid%order+2 + end select + end if + end subroutine conv_GetNProbes + + !---------------------------------------------------------------------- + ! Sets the exact form of the probes... Only works for order<0 for now. + recursive subroutine conv_SetProbes(grid,probes) + type(grid_def), intent(in) :: grid + real(dp), intent(out) :: probes(0:,:) + integer :: isub, iprobe + if (grid%nsub /= 0) then + do isub = 1, grid%nsub + call conv_SetProbes(grid%subgd(isub),& + &probes(grid%subiy(isub):grid%subiy(isub+1)-1,:)) + end do + else + select case(grid%order) + case(:LIN_ORDER-1) + probes(0,1) = one + probes(1:,:) = zero + case(LIN_ORDER) + probes(:,:) = zero + probes(0,1) = one + probes(1,2) = one + case(LIN_ORDER+1:) + probes = zero + do iprobe = 1, grid%order+2 + probes(iprobe-1,iprobe) = one + end do + end select + end if + end subroutine conv_SetProbes + + + !---------------------------------------------------------------------- + ! Does the work in the setup of the "derived" convolution operator. + recursive subroutine SetDerivedConv_nodealloc(gc,probes) + use warnings_and_errors + real(dp), intent(in) :: probes(0:,:) + type(grid_conv), intent(inout) :: gc + integer :: isub, order, iprobe + + override_grid_locking = .false. + if (nconv_with_override_off /= 0) call wae_error(& + &'SetDerivedConv_nodealloc',& + &'Detected convolutions while lock overried off') + + if (gc%grid%nsub /= 0) then + do isub = 1, gc%grid%nsub + call SetDerivedConv_nodealloc(gc%subgc(isub),& + &probes(gc%grid%subiy(isub):gc%grid%subiy(isub+1)-1,:)) + end do + else + select case(gc%grid%order) + case(:LIN_ORDER-1) + gc%conv = probes + case(LIN_ORDER) + gc%conv(0:gc%grid%ny-1,FULL) = probes(1:,2) + ! fake value here -- but since we will actually only be + ! interested in lower for this point, it does not + ! matter! + gc%conv(gc%grid%ny,FULL) = zero + ! actually it is lower that has been calculated here + gc%conv(0:,UPPR) = probes(0:,1) + ! now convert it to upper + gc%conv(0:,UPPR) = gc%conv(0:,FULL) - gc%conv(0:,UPPR) + case(LIN_ORDER+1:) + order = gc%grid%order + ! a safety check -- if I forget anything it should + ! jump out... + gc%conv = 1e90_dp ! dummy value to detect uninitialized pieces... + do iprobe = 1, order+1 + gc%conv(:,iprobe) = probes(:,order+2-iprobe) + end do + gc%conv(0:gc%grid%ny-order-1,0) = probes(order+1:,order+2) + ! originally known, but unknowable with this method (and + ! irrelevant). + gc%conv(gc%grid%ny-order:,0) = zero + end select + end if + end subroutine SetDerivedConv_nodealloc + +end module convolution diff --git a/src/dglap_choices.f90 b/src/dglap_choices.f90 new file mode 100644 index 0000000..c3c2910 --- /dev/null +++ b/src/dglap_choices.f90 @@ -0,0 +1,51 @@ +!! +!! Parameters describing the range of possible "options" in the +!! DGLAP evolution. Options refer both to physical choices (such +!! as schemes, polarization) as well as technical choices (choice of +!! approximation used for NNLO splitting function). +!! +!! GPS: adapted from qcd.f90 18/09/2004 +!! +module dglap_choices + implicit none + private + + integer, parameter, public :: nnlo_splitting_exact = -2 + integer, parameter, public :: nnlo_splitting_param = -1 + ! these three should keep their numerical values because + ! of a correspondence with vogt imod values + integer, parameter, public :: nnlo_splitting_Nfitav = 0 + integer, parameter, public :: nnlo_splitting_Nfiterr1 = 1 + integer, parameter, public :: nnlo_splitting_Nfiterr2 = 2 + integer, public :: nnlo_splitting_variant = nnlo_splitting_param + + integer, parameter, public :: nnlo_nfthreshold_exact = -12 + integer, parameter, public :: nnlo_nfthreshold_param = -11 + integer, public :: nnlo_nfthreshold_variant = nnlo_nfthreshold_param + + integer, parameter, public :: factscheme_MSbar = 1 + integer, parameter, public :: factscheme_DIS = 2 + integer, parameter, public :: factscheme_PolMSbar = 3 + ! have these on split lines so that they are not caught + ! by naming routines. + integer, parameter,& + & public :: factscheme_default = factscheme_MSbar + integer, parameter, & + &public :: factscheme_Poldefault = factscheme_PolMSbar + + public :: dglap_Set_nnlo_splitting + public :: dglap_Set_nnlo_nfthreshold +contains + + !-------- overkill ---------------------------------------- + subroutine dglap_Set_nnlo_splitting(variant) + integer, intent(in) :: variant + nnlo_splitting_variant = variant + end subroutine dglap_Set_nnlo_splitting + + !-------- overkill ---------------------------------------- + subroutine dglap_Set_nnlo_nfthreshold(variant) + integer, intent(in) :: variant + nnlo_nfthreshold_variant = variant + end subroutine dglap_Set_nnlo_nfthreshold +end module dglap_choices diff --git a/src/dglap_holders.f90 b/src/dglap_holders.f90 new file mode 100644 index 0000000..441d395 --- /dev/null +++ b/src/dglap_holders.f90 @@ -0,0 +1,354 @@ +!====================================================================== +!! Module containing the definition of the dglap_holder type, together +!! with various related subroutines. +!! +!! The dglap_holder type is intended to contain all splitting +!! functions and coefficient functions related to PDF evolution and +!! F2/FL convolutions. As of (5/5/2006 -- actually for a long time +!! now), the coefficient function part is not fully implemented, +!! whereas all the splitting functions are. +!! +module dglap_holders + use types; use consts_dp + use dglap_objects + use pdf_representation + use assertions; use warnings_and_errors + implicit none + private + + !-- + !! Everything needed to calculate a cross section, given structure + !! functions and alpha_s. + !! + ! nomenclature is: objects are leading order, unless there is a suffix n, + ! in which case they are NLO. + type dglap_holder + type(grid_def) :: grid + !----------------------- nloop, nf -------------- + type(split_mat), pointer :: allP(:, :) + type(split_mat), pointer :: P_LO, P_NLO, P_NNLO + type(coeff_mat), pointer :: allC(:,:) + type(coeff_mat), pointer :: C2, C2_1, CL_1 + !-- indep of nf for the time being ---------------- + type(mass_threshold_mat) :: MTM2 + logical :: MTM2_exists=.false. + integer :: factscheme, nloop + !-------------------------------- nf ------------ + !type(pdf_rep), pointer :: all_prep(:) + !type(pdf_rep), pointer :: prep + integer :: nf + end type dglap_holder + + !-- this is potentially makeshift? + integer, parameter :: nC = 3 + + public :: dglap_holder, InitDglapHolder, SetNfDglapHolder + + interface Delete + module procedure holder_Delete + end interface + public :: Delete + +contains + + !------------------------------------------------------- + ! Sets up eveything needed to calculate cross sections + ! i.e. splitting functions and coefficient functions + subroutine InitDglapHolder(grid, dh, factscheme, nloop, nflo, nfhi) + use coefficient_functions; use convolution + use qcd; use dglap_choices + type(grid_def), intent(in) :: grid + type(dglap_holder), intent(inout), target :: dh + integer, optional, intent(in) :: factscheme + integer, optional, intent(in) :: nloop + integer, optional, intent(in) :: nflo, nfhi + !-- holds temporary results + type(grid_conv) :: dconv + !-- holds all possible combinations of coefficient and splitting functions + ! needed for DIS schemes + type(grid_conv) :: Cq,Cg + type(grid_conv) :: CqPqq, CqPqg, CqPgq, CqPgg + type(grid_conv) :: CgPqq, CgPqg, CgPgq, CgPgg + !-- more compactly written version of DIS scheme + type(grid_conv) :: CC(iflv_g:iflv_sigma,iflv_g:iflv_sigma) + type(grid_conv) :: tmp2d(iflv_g:iflv_sigma,iflv_g:iflv_sigma) + logical :: newDIS = .true. + !logical :: newDIS = .false. + integer :: nfstore, nflcl + + dh%factscheme = default_or_opt(factscheme_default, factscheme) + dh%nloop = default_or_opt(2, nloop) + if (dh%nloop > 3 .or. dh%nloop < 1) then + call wae_error('InitDglapHolder: nloop must be between 1 and 3') + end if + dh%grid = grid + + if (present(nflo) .and. present(nfhi)) then + allocate(dh%allP(dh%nloop,nflo:nfhi)) + !allocate(dh%all_prep(nflo:nfhi)) + allocate(dh%allC(nC,nflo:nfhi)) + else + !-- otherwise, use whatever nf is currently set + allocate(dh%allP(dh%nloop,nf_int:nf_int)) + !allocate(dh%all_prep(nf_int:nf_int)) + allocate(dh%allC(nC,nf_int:nf_int)) + end if + + !-- want to reset it at end + nfstore = nf_int + + do nflcl = lbound(dh%allP,dim=2), ubound(dh%allP,dim=2) + !-- this sets up all the pointers to make it look like a fixed-nf + ! dh! + call SetNfDglapHolder(dh, nflcl) + + !----- this is the remainder, essentially unchanged ---- + select case (dh%factscheme) + case (factscheme_MSbar) + call InitSplitMatLO (grid, dh%P_LO) + if (dh%nloop >= 2) call InitSplitMatNLO(grid, dh%P_NLO, dh%factscheme) + if (dh%nloop >= 3) then + call InitSplitMatNNLO(grid, dh%P_NNLO, dh%factscheme) + !-- do this once, and only if really needed + if (lbound(dh%allP,dim=2) /= ubound(dh%allP,dim=2) & + &.and. mass_steps_on & + &.and. nflcl == lbound(dh%allP,dim=2)) then + call InitMTMNNLO(grid,dh%MTM2) + dh%MTM2_exists = .true. + end if + end if + + call cobj_InitCoeff(grid, dh%C2) + call cobj_InitCoeff(grid, dh%C2_1, cf_CgF2MSbar, cf_CqF2MSbar) + call cobj_InitCoeff(grid, dh%CL_1, cf_CgFL, cf_CqFL) + case (factscheme_DIS) + call InitSplitMatLO (grid, dh%P_LO) + if (dh%nloop >= 2) & + &call InitSplitMatNLO(grid, dh%P_NLO, factscheme_MSbar) + if (dh%nloop >= 3) write(0,*) & + &'DIS factorisation scheme not supported for 3 loops or more' + call cobj_InitCoeff(grid, dh%C2) + call cobj_InitCoeff(dh%C2_1, dh%C2, zero) + call cobj_InitCoeff(grid, dh%CL_1, cf_CgFL, cf_CqFL) + + !-- now convert MSbar splitting functions into DIS scheme ------- + ! See CCN21-6 (and also CCN17-61) + + if (newDIS) then + ! + ! NB THIS VERSION OF THE DIS SCHEME IS NOT YET IN AGREEMENT + ! WITH THE OLDER VERSION... + ! ACTUALLY: THIS IS PROBABLY NO LONGER TRUE? + !-- create the matrix C for use in + ! P_matrix -> P_matrix + [C,P] + ! / Cq Cg \ + ! C == | | where Cg includes 2nf factor + ! \ -Cq -Cg / + call InitGridConv(grid,CC(iflv_sigma,iflv_sigma),cf_CqF2MSbar) + call InitGridConv(grid,CC(iflv_sigma,iflv_g), cf_CgF2MSbar) + call Multiply(CC(iflv_sigma,iflv_g), two*nf) + call InitGridConv(CC(iflv_g,:),CC(iflv_sigma,:),-one) + !-- now get a temporary to hold the commutator + call AllocGridConv(grid,tmp2d) + !-- work out the commutator: tmp2d=[C,P] + !write(0,*) 'lb',lbound(dh%P_LO%singlet), ubound(dh%P_LO%singlet) + !write(0,*) 'dh%P_LO%singlet(0,0)%nsub',dh%P_LO%singlet(0,0)%grid%nsub + !write(0,*) 'dh%P_LO%singlet(0,1)%nsub',dh%P_LO%singlet(0,1)%grid%nsub + !----------------------------------------------- + ! putting the explicit singlet bounds somehow eliminates + ! an ifc memory error, which was associated with + ! gcb in SetToCommutator obtaining ubound=(/220,1/) + ! No understanding of origin of error and locally + ! singlet has right bounds + ! + ! result however seems to be wrong. + ! + ! Message: be wary of intel here + !call SetToCommutator(tmp2d,CC,dh%P_LO%singlet(iflv_g:iflv_sigma,iflv_g:iflv_sigma)) + call SetToCommutator(tmp2d,CC,dh%P_LO%singlet) + !-- add it to P1 + call AddWithCoeff(dh%P_NLO%singlet,tmp2d) + !-- add the beta function pieces as well + call AddWithCoeff(dh%P_NLO%singlet,CC, -twopi_beta0) + call AddWithCoeff(dh%P_NLO%NS_plus, CC(iflv_sigma,iflv_sigma),& + & -twopi_beta0) + !-- quark number conservation remains OK because + ! Cq has the om=0 moment equal to zero. + call AddWithCoeff(dh%P_NLO%NS_minus, CC(iflv_sigma,iflv_sigma), & + &-twopi_beta0) + call AddWithCoeff(dh%P_NLO%NS_V, CC(iflv_sigma,iflv_sigma), & + &-twopi_beta0) + + !-- clean up + call Delete(CC) + call Delete(tmp2d) + else + call InitGridConv(grid, Cq, cf_CqF2MSbar) + call InitGridConv(grid, Cg, cf_CgF2MSbar) + call Multiply(Cg, two*nf) + ! where possible put the smoother distribution to the right + ! (only makes a difference when pdfs are non zero at x=1?) + call conv_ConvConv(CqPqq, Cq, dh%P_LO%qq) + call conv_ConvConv(CqPqg, Cq, dh%P_LO%qg) + call conv_ConvConv(CqPgq, Cq, dh%P_LO%gq) + call conv_ConvConv(CqPgg, Cq, dh%P_LO%gg) + call conv_ConvConv(CgPqq, dh%P_LO%qq, Cg) + call conv_ConvConv(CgPqg, dh%P_LO%qg, Cg) + call conv_ConvConv(CgPgq, dh%P_LO%gq, Cg) + call conv_ConvConv(CgPgg, dh%P_LO%gg, Cg) + + ! + ! First deal with P_matrix -> P_matrix + [C,P] + ! / Cq Cg \ + ! C == | | where Cg includes 2nf factor + ! \ -Cq -Cg / + ! + ! Pqq -> Pqq + (Cg Pgq + Cq Pqg) + call AddWithCoeff(dh%P_NLO%qq, CgPgq, one) + call AddWithCoeff(dh%P_NLO%qq, CqPqg, one) + ! Pqg -> Pqg + (Cq Pqg + Cg Pgg - Cg Pqq + Cg Pqg) + call AddWithCoeff(dh%P_NLO%qg, CqPqg, one) + call AddWithCoeff(dh%P_NLO%qg, CgPgg, one) + call AddWithCoeff(dh%P_NLO%qg, CgPqq,-one) + call AddWithCoeff(dh%P_NLO%qg, CgPqg, one) + ! Pgq -> Pqg + (-Cq Pqq - Cg Pgq - Cq Pgq + Cq Pgg) + call AddWithCoeff(dh%P_NLO%gq, CqPqq,-one) + call AddWithCoeff(dh%P_NLO%gq, CgPgq,-one) + call AddWithCoeff(dh%P_NLO%gq, CqPgq,-one) + call AddWithCoeff(dh%P_NLO%gq, CqPgg, one) + ! Pgg -> Pgg + (-Cq Pqg - Cg Pgq) + call AddWithCoeff(dh%P_NLO%gg, CqPqg,-one) + call AddWithCoeff(dh%P_NLO%gg, CgPgq,-one) + ! + ! Now deal with P_matrix -> P_matrix - beta0 * C + ! P_+ -> P_+ - beta0 * C_q + call AddWithCoeff(dh%P_NLO%qq, Cq, -twopi_beta0) + call AddWithCoeff(dh%P_NLO%qg, Cg, -twopi_beta0) + call AddWithCoeff(dh%P_NLO%gq, Cq, +twopi_beta0) + call AddWithCoeff(dh%P_NLO%gg, Cg, +twopi_beta0) + call AddWithCoeff(dh%P_NLO%NS_plus, Cq, -twopi_beta0) + !-- quark number conservation remains OK because + ! Cq has the om=0 moment equal to zero. + call AddWithCoeff(dh%P_NLO%NS_minus, Cq, -twopi_beta0) + call AddWithCoeff(dh%P_NLO%NS_V, Cq, -twopi_beta0) + ! + ! tidy up + !write(0,*) 'Hey:',dh%P_LO%singlet(0,0)%subgc(1)%conv(0:3,1) + !write(0,*) 'Hey:',dh%P_LO%singlet(0,1)%subgc(1)%conv(0:3,1) + !write(0,*) 'Hey:',dh%P_LO%singlet(1,0)%subgc(1)%conv(0:3,1) + !write(0,*) 'Hey:',dh%P_LO%singlet(1,1)%subgc(1)%conv(0:3,1) + !write(0,*) 'Hey:', Cq%subgc(1)%conv(0:3,1) + !write(0,*) 'Hey:', Cg%subgc(1)%conv(0:3,1) + + call Delete(Cq) + call Delete(Cg) + call Delete(CqPqq) + call Delete(CqPqg) + call Delete(CqPgq) + call Delete(CqPgg) + call Delete(CgPqq) + call Delete(CgPqg) + call Delete(CgPgq) + call Delete(CgPgg) + write(0,*) 'result:',dh%P_NLO%singlet(iflv_sigma,iflv_sigma)%conv(10,1) + end if + + case (factscheme_PolMSbar) + write(0,*) "SETTING UP POLARIZED EVOLUTION" + call InitSplitMatPolLO (grid, dh%P_LO) + if (dh%nloop >= 2) call InitSplitMatPolNLO(grid, & + &dh%P_NLO, dh%factscheme) + if (dh%nloop >= 3) call wae_error('InitDglapHolder',& + &'nloop >= 3 not supported for polarized case') + case default + write(0,*) 'factorisation scheme ',dh%factscheme,& + &' is not currently supported' + stop + end select + + !-- used for converting to and from the evolution representation + !dh%prep = DefaultEvlnRep(nf_int) +!!$ dh%prep%nf = nf_int +!!$ !dh%prep%ibase = nf_int +!!$ dh%prep%ibase = 1 + end do + + + + !-- be "clean", put nf back to where it was ---------- + if (nfstore <= ubound(dh%allP,2) .and. nfstore >= lbound(dh%allP,2)) then + ! set it in the dglap holder as well if valid + call SetNfDglapHolder(dh,nfstore) + else + ! set it just in the global qcd module, because it is not + ! valid here... + call qcd_SetNf(nfstore) + end if + + end subroutine InitDglapHolder + + + !-------------------------------------------------------------- + ! set up all pointers so that it looks like an old holder in the + ! good-old fixed-nf days; it also sets the global nf. + ! (NB: perhaps that is not too good?) + subroutine SetNfDglapHolder(dh, nflcl) + use qcd + type(dglap_holder), intent(inout) :: dh + integer, intent(in) :: nflcl + + if (nflcl < lbound(dh%allP,dim=2) .or. nflcl > ubound(dh%allP,dim=2)) then + call wae_Error('SetNfDglapHolder: tried to set unsupported nf; request val was',intval=nflcl) + end if + + !-- want general nf to be consistent. Not really all that nice a + ! way of doing things, but cannot think of a better solution + ! given the current structure... + call qcd_SetNf(nflcl) + if (dh%mtm2_exists) call SetNfMTM(dh%MTM2, nflcl) + + !-- set up links so that the remainder of the routine + ! can stay unchanged + dh%P_LO => dh%allP(1,nflcl) + if (dh%nloop >= 2) then + dh%P_NLO => dh%allP(2,nflcl) + else + nullify(dh%P_NLO) + end if + + if (dh%nloop >= 3) then + dh%P_NNLO => dh%allP(3,nflcl) + else + nullify(dh%P_NNLO) + end if + + dh%C2 => dh%allC(1,nflcl) + dh%C2_1 => dh%allC(2,nflcl) + dh%CL_1 => dh%allC(3,nflcl) + !dh%prep => dh%all_prep(nflcl) + dh%nf = nflcl + end subroutine SetNfDglapHolder + + !====================================================================== + !! Attempt to free up all memory associated with this holder + subroutine holder_Delete(dh) + type(dglap_holder), intent(inout) :: dh + !-------------------------------------- + integer :: nflcl, iloop + + do nflcl = lbound(dh%allP,2), ubound(dh%allP,2) + do iloop = 1, dh%nloop + call Delete(dh%allP(iloop,nflcl)) + call Delete(dh%allC(iloop,nflcl)) + end do + end do + + if (dh%MTM2_exists) call Delete(dh%MTM2) + + deallocate(dh%allP) + deallocate(dh%allC) + !deallocate(dh%all_prep) + end subroutine holder_Delete + + +end module dglap_holders diff --git a/src/dglap_objects.f90 b/src/dglap_objects.f90 new file mode 100644 index 0000000..37792d4 --- /dev/null +++ b/src/dglap_objects.f90 @@ -0,0 +1,1009 @@ +!====================================================================== +! +!! This module provide a type for matrices of splitting functions as +!! well as for coefficient functions and mass-threshold matrices. The +!! two latter ones are liable to evolve. +!! +!! The module also provides: +!! +!! - subroutines for manipulating the splitting matrices (similarly +!! to the subroutine for grid_conv objects) +!! +!! - subroutines for initialising the splitting matrices with the LO +!! NLO and NNLO splitting functions +!! +!! - subroutines for initialising Polarised LO and NLO splitting matrices. +!! +!! - mass thresholds, coefficient functions, +!! +!! - tools for getting "derived" splitting matrices. +!! +!====================================================================== +module dglap_objects + use types; use consts_dp; use splitting_functions + !use qcd + use dglap_choices + use warnings_and_errors + use pdf_representation + use convolution + use assertions + implicit none + private + + !----------------------------------------------------------------- + ! holds all the components of the splitting functions + type split_mat + !private + !-- These are the singlet evolution pieces + ! qg is defined including a 2nf factor + type(grid_conv) :: singlet(iflv_g:iflv_sigma,iflv_g:iflv_sigma) + type(grid_conv), pointer :: gg, qq, gq, qg + !-- These are the non-singlet pieces + type(grid_conv) :: NS_plus, NS_minus, NS_V + !-- LO -> loops=1, etc... + !integer :: loops ! [not needed anymore?] + integer :: nf_int + end type split_mat + public :: split_mat + + !--------------------------------------------------------------- + ! for going from nf to nf+1. Currently contains pieces + ! required for O(as^2), but not the full general structure. + ! Initially, support for this might be a bit limited? + type mass_threshold_mat + type(grid_conv) :: PShq, PShg + type(grid_conv) :: NSqq_H, Sgg_H, Sgq_H + ! LOOPS == 1+POWER OF AS2PI, NF_INT = nf including heavy quark. + ! This is potentially adaptable. + integer :: loops, nf_int + end type mass_threshold_mat + public :: mass_threshold_mat + + !----------------------------------------------------------------- + ! holds the components of a coefficient function + type coeff_mat + !private + !-- need a grid def. Sometimes no g or q will be defined + ! but still want the coefficient function associated with a grid + ! def + ! delta is the magnitude of a delta function piece + ! quark charge contributions are included by the routines here. + ! for gluons the implicitness is \sum_{q,qbar} e_q^2 + type(grid_def) :: grid + type(grid_conv) :: g, q + real(dp) :: delta + logical :: HO + end type coeff_mat + public :: coeff_mat + + + !---------- avoid need for main program to access convolution + ! give it both possible names. Maybe not necessary? + public :: grid_def + interface cobj_InitGridDef + ! perhaps illegal, so do it explicitly? + !module procedure InitGridDef + module procedure conv_InitGridDef_single, conv_InitGridDef_multi + end interface + public :: cobj_InitGridDef + public :: InitGridDef + + public :: InitSplitMatLO, InitSplitMatNLO + public :: InitSplitMatNNLO + public :: InitSplitMatPolLO, InitSplitMatPolNLO + + public :: InitSplitMat!, Delete_sm + !public :: AddWithCoeff_sm, Multiply_sm + !public :: cobj_PConv, cobj_PConv_1d + + public :: InitMTMNNLO, SetNfMTM, cobj_ConvMTM, cobj_DelMTM + + !-------- things for splitting functions -------------------- + interface cobj_InitCoeff + module procedure cobj_InitCoeffLO, cobj_InitCoeffHO, cobj_InitCoeff_cf + end interface + public :: cobj_InitCoeff, cobj_InitCoeffLO, cobj_InitCoeffHO + !public :: cobj_CConv + public :: cobj_AddCoeff, cobj_DelCoeff + public :: GetDerivedSplitMatProbes, AllocSplitMat, SetDerivedSplitMat + + + interface operator(*) + module procedure cobj_PConv, cobj_PConv_1d, cobj_CConv, cobj_ConvMTM + end interface + public :: operator(*) + interface operator(.conv.) + module procedure cobj_PConv, cobj_PConv_1d, cobj_CConv, cobj_ConvMTM + end interface + public :: operator(.conv.) + public :: cobj_Eval2LConv + !-- avoid access through here + private :: cobj_PConv, cobj_PConv_1d, cobj_CConv + + interface SetToZero + module procedure SetToZero_sm + end interface + public :: SetToZero + + interface Multiply + module procedure Multiply_sm + end interface + public :: Multiply + + interface AddWithCoeff + module procedure AddWithCoeff_sm + end interface + public :: AddWithCoeff + + interface SetToConvolution + module procedure SetToConvolution_sm + end interface + public :: SetToConvolution + + interface SetToCommutator + module procedure SetToCommutator_sm + end interface + public :: SetToCommutator + + interface Delete + module procedure Delete_sm, cobj_DelMTM, cobj_DelCoeff + end interface + public :: Delete + + +contains + + !====================================================================== + !! make sure all required internal links are set up for the splitting + !! matrix + subroutine cobj_InitSplitLinks(P) + type(split_mat), target, intent(inout) :: P + + if ((iflv_sigma - iflv_g) /= 1) call wae_error(& + &'cobj_InitSplitLinks:', 'local gluon and sigma ids not consistent') + + !-- NB singlet matrix is not written with usual convention of + ! (sigma g), but rather (g sigma) + P%gg => P%singlet(iflv_g,iflv_g) + P%gq => P%singlet(iflv_g,iflv_sigma) + P%qg => P%singlet(iflv_sigma,iflv_g) + P%qq => P%singlet(iflv_sigma,iflv_sigma) + end subroutine cobj_InitSplitLinks + + + !====================================================================== + !! Initialise a LO unpolarised splitting matrix, with the nf value that + !! is current from the qcd module. + subroutine InitSplitMatLO(grid, P) + use qcd + type(grid_def), intent(in) :: grid + type(split_mat), intent(inout) :: P + + !-- info to describe the splitting function + !P%loops = 1 + P%nf_int = nf_int + + call cobj_InitSplitLinks(P) + + call InitGridConv(grid, P%gg, sf_Pgg) + call InitGridConv(grid, P%qq, sf_Pqq) + call InitGridConv(grid, P%gq, sf_Pgq) + call InitGridConv(grid, P%qg, sf_Pqg) + + !-- now fix up pieces so that they can be directly used as a matrix + call Multiply(P%qg, 2*nf) + + !-- PqqV +- PqqbarV + call InitGridConv(P%NS_plus, P%qq) + call InitGridConv(P%NS_minus, P%qq) + + !-- PNSminus + nf * (PqqS - PqqbarS) + call InitGridConv(P%NS_V, P%NS_minus) + end subroutine InitSplitMatLO + + + !====================================================================== + !! Initialise a NLO unpolarised splitting matrix, with the nf value that + !! is current from the qcd module. (MSbar scheme) + subroutine InitSplitMatNLO(grid, P, factscheme) + use qcd + type(grid_def), intent(in) :: grid + type(split_mat), intent(inout) :: P + integer, optional, intent(in) :: factscheme + integer :: factscheme_local + !----------------------------------------- + type(grid_conv) :: P1qqV, P1qqbarV, P1qqS + !-- needed for DIS schemes + type(grid_conv) :: Cq,Cg + type(grid_conv) :: CqPqq, CqPqg, CqPgq, CqPgg + type(grid_conv) :: CgPgg, CgPqg, CgPgq, CgPqq + + + factscheme_local = default_or_opt(factscheme_default, factscheme) + if (factscheme_local /= factscheme_MSbar) then + ! NB: do not support DIS scheme here since it involves + ! determination of Pqq etc at LO (already done once, so do + ! not want to repeat) -- rather do this stuff in + ! dglap_holders, where Pqq(LO) will in any case be available. + ! (Is this "chickening out"?) + write(0,*) 'InitSplitMatNLO: unsupported fact scheme', factscheme + call wae_error('InitSplitMatNLO: stopping') + end if + + !-- info to describe the splitting function + !P%loops = 2 + P%nf_int = nf_int + + call cobj_InitSplitLinks(P) + + !-- these are the building blocks + call InitGridConv(grid, P1qqV, sf_P1qqV) + call InitGridConv(grid, P1qqbarV, sf_P1qqbarV) + call InitGridConv(grid, P1qqS, sf_P1qqS) + + !-- PqqV + PqqbarV + call InitGridConv(P%NS_plus, P1qqV) + call AddWithCoeff(P%NS_plus, P1qqbarV, one) + !-- PqqV - PqqbarV + call InitGridConv(P%NS_minus, P1qqV) + call AddWithCoeff(P%NS_minus, P1qqbarV, -one) + + !-- PNSminus + nf * (PqqS - PqqbarS) + ! [NB at NLO, PqqS = PqqbarS] + call InitGridConv(P%NS_V, P%NS_minus) + + !-- Pqq in matrix: PNS_plus + nf*(PqqS + PqqbarS) + ! [NB at NLO, PqqS = PqqbarS] + call InitGridConv(P%qq, P%NS_plus) + call AddWithCoeff(P%qq, P1qqS, two*nf) + + !-- rest of singlet matrix + call InitGridConv(grid, P%gq, sf_P1gq) + call InitGridConv(grid, P%gg, sf_P1gg) + call InitGridConv(grid, P%qg, sf_P1qg) + !-- recall that the way it is defined it needs a factor 2nf + call Multiply(P%qg, two*nf) + + !-- tidy up + call Delete(P1qqV) + call Delete(P1qqbarV) + call Delete(P1qqS) + + end subroutine InitSplitMatNLO + + + + !====================================================================== + !! Initialise a NNLO unpolarised splitting matrix, with the nf value that + !! is current from the qcd module. (MSbar scheme) + subroutine InitSplitMatNNLO(grid, P, factscheme) + use qcd; use convolution_communicator + type(grid_def), intent(in) :: grid + type(split_mat), intent(inout) :: P + integer, optional, intent(in) :: factscheme + integer :: factscheme_local + !----------------------------------------- + type(grid_conv) :: P2NSS + real(dp) :: dummy + + !call wae_error('InitSplitMatNNLO: NNLO not yet implemented') + factscheme_local = default_or_opt(factscheme_default, factscheme) + if (factscheme_local /= factscheme_MSbar) then + write(0,*) 'InitSplitMatNNLO: unsupported fact scheme', factscheme + call wae_error('InitSplitMatNNLO: stopping') + end if + + !-- info to describe the splitting function + !P%loops = 3 + P%nf_int = nf_int + + ! NO LONGER NECESSARY +!!$ !-- dummy to initialize Vogt routines (needed in exact cases +!!$ ! for the A3 piece to be set up). Do it better later on if it works? +!!$ cc_piece = cc_real +!!$ dummy = sf_P2NSMinus(0.5_dp) +!!$ dummy = sf_P2gg(0.5_dp) + + call cobj_InitSplitLinks(P) + + call InitGridConv(grid, P%NS_plus, sf_P2NSPlus) + call InitGridConv(grid, P%NS_minus, sf_P2NSMinus) + + !-- if understanding of convention is right then P_V = P_- + P_S + call InitGridConv(P%NS_V, P%NS_minus) + call InitGridConv(grid, P2NSS, sf_P2NSS) + call AddWithCoeff(P%NS_V, P2NSS) + call Delete(P2NSS) + + !-- now the singlet functions + call InitGridConv(grid, P%qg, sf_P2qg2nf) + call InitGridConv(grid, P%gg, sf_P2gg) + call InitGridConv(grid, P%gq, sf_P2gq) + !-- qq = "pure-singlet" + P+ + call InitGridConv(grid, P%qq, sf_P2PS) + call AddWithCoeff(P%qq, P%NS_plus) + end subroutine InitSplitMatNNLO + + + !====================================================================== + !! Initialise a LO Polarised splitting matrix, with the nf value that + !! is current from the qcd module. + subroutine InitSplitMatPolLO(grid, P) + use qcd + type(grid_def), intent(in) :: grid + type(split_mat), intent(inout) :: P + + !-- info to describe the splitting function + !P%loops = 1 + P%nf_int = nf_int + + call cobj_InitSplitLinks(P) + + call InitGridConv(grid, P%gg, sf_DPgg) + call InitGridConv(grid, P%qq, sf_DPqq) + call InitGridConv(grid, P%gq, sf_DPgq) + call InitGridConv(grid, P%qg, sf_DPqg) + + !-- now fix up pieces so that they can be directly used as a matrix + call Multiply(P%qg, 2*nf) + + !-- PqqV +- PqqbarV + call InitGridConv(P%NS_plus, P%qq) + call InitGridConv(P%NS_minus, P%qq) + + !-- PNSminus + nf * (PqqS - PqqbarS) + call InitGridConv(P%NS_V, P%NS_minus) + end subroutine InitSplitMatPolLO + + !====================================================================== + !! Initialise a NLO Polarised splitting matrix, with the nf value that + !! is current from the qcd module. + subroutine InitSplitMatPolNLO(grid, P, factscheme) + use qcd + type(grid_def), intent(in) :: grid + type(split_mat), intent(inout) :: P + integer, optional, intent(in) :: factscheme + integer :: factscheme_local + !----------------------------------------- + type(grid_conv) :: DP1qqV, DP1qqbarV, DP1qqS + + factscheme_local = default_or_opt(factscheme_Poldefault, factscheme) + if (factscheme_local /= factscheme_PolMSbar) then + ! NB: do not support DIS scheme here since it involves + ! determination of Pqq etc at LO (already done once, so do + ! not want to repeat) -- rather do this stuff in + ! dglap_holders, where Pqq(LO) will in any case be available. + ! (Is this "chickening out"?) + write(0,*) 'InitSplitMatPolNLO: unsupported fact scheme', factscheme + call wae_error('InitSplitMatPolNLO: stopping') + end if + + !-- info to describe the splitting function + !P%loops = 2 + P%nf_int = nf_int + + call cobj_InitSplitLinks(P) + + !-- these are the building blocks + call InitGridConv(grid, DP1qqV, sf_DP1qqV) + call InitGridConv(grid, DP1qqbarV, sf_DP1qqbarV) + call InitGridConv(grid, DP1qqS, sf_DP1qqS) + + !-- PqqV + PqqbarV + call InitGridConv(P%NS_plus, DP1qqV) + call AddWithCoeff(P%NS_plus, DP1qqbarV, one) + !-- PqqV - PqqbarV + call InitGridConv(P%NS_minus, DP1qqV) + call AddWithCoeff(P%NS_minus, DP1qqbarV, -one) + + !-- PNSminus + nf * (PqqS - PqqbarS) + ! [NB at NLO, PqqS = PqqbarS] + call InitGridConv(P%NS_V, P%NS_minus) + + !-- Pqq in matrix: PNS_plus + nf*(PqqS + PqqbarS) + ! [NB at NLO, PqqS = PqqbarS] + call InitGridConv(P%qq, P%NS_plus) + call AddWithCoeff(P%qq, DP1qqS, two*nf) + + !-- rest of singlet matrix + call InitGridConv(grid, P%gq, sf_DP1gq) + call InitGridConv(grid, P%gg, sf_DP1gg) + call InitGridConv(grid, P%qg, sf_DP1qg) + !-- recall that the way it is defined it needs a factor 2nf + call Multiply(P%qg, two*nf) + + !-- tidy up + call Delete(DP1qqV) + call Delete(DP1qqbarV) + call Delete(DP1qqS) + + end subroutine InitSplitMatPolNLO + + + !---------------------------------------------------------------------- + !! initialize a splitting function matrix with another one (potentially + !! multiplied by some factor). Memory allocation should be automatically + !! handled by the subsiduary routines. + subroutine InitSplitMat(P, Pin, factor) + type(split_mat), intent(inout) :: P + type(split_mat), intent(in) :: Pin + real(dp), intent(in), optional :: factor + !if (nf_d /= (nf_int+1)/2) write(0,*) 'WARNING: non-standard nf_d' + + !P%loops = Pin%loops + P%nf_int = Pin%nf_int + call cobj_InitSplitLinks(P) + + call InitGridConv(P%gg, Pin%gg, factor) + call InitGridConv(P%qq, Pin%qq, factor) + call InitGridConv(P%gq, Pin%gq, factor) + call InitGridConv(P%qg, Pin%qg, factor) + + !-- from here on, one could exploit info in loops so as to + ! reduce number of multiplications... But I am too lazy in this first + ! go + call InitGridConv(P%NS_plus, Pin%NS_plus, factor) + call InitGridConv(P%NS_minus, Pin%NS_minus, factor) + call InitGridConv(P%NS_V, Pin%NS_V, factor) + + end subroutine InitSplitMat + + + !---------------------------------------------------------------------- + !! init a splitting function set with another one (potentially + !! multiplied by some factor) + subroutine AddWithCoeff_sm(P, Padd, factor) + type(split_mat), intent(inout) :: P + type(split_mat), intent(in) :: Padd + real(dp), intent(in), optional :: factor + !if (nf_d /= (nf_int+1)/2) write(0,*) 'WARNING: non-standard nf_d' + + !P%loops = max(P%loops, Padd%loops) + P%nf_int = assert_eq(P%nf_int, Padd%nf_int, & + &'AddWithCoeff_sm: nf must be the same') + call AddWithCoeff(P%gg, Padd%gg, factor) + call AddWithCoeff(P%qq, Padd%qq, factor) + call AddWithCoeff(P%gq, Padd%gq, factor) + call AddWithCoeff(P%qg, Padd%qg, factor) + call AddWithCoeff(P%NS_plus, Padd%NS_plus, factor) + call AddWithCoeff(P%NS_minus, Padd%NS_minus, factor) + call AddWithCoeff(P%NS_V, Padd%NS_V, factor) + + end subroutine AddWithCoeff_sm + + + !---------------------------------------------------------------------- + !! Multiply the splitting matrix P by factor. + subroutine Multiply_sm(P, factor) + type(split_mat), intent(inout) :: P + real(dp), intent(in) :: factor + !if (nf_d /= (nf_int+1)/2) write(0,*) 'WARNING: non-standard nf_d' + + call Multiply(P%gg, factor) + call Multiply(P%qq, factor) + call Multiply(P%gq, factor) + call Multiply(P%qg, factor) + call Multiply(P%NS_plus, factor) + call Multiply(P%NS_minus, factor) + call Multiply(P%NS_V, factor) + + end subroutine Multiply_sm + + + !====================================================================== + !! Set the splitting matrix P to zero + subroutine SetToZero_sm(P) + type(split_mat), intent(inout) :: P + + call SetToZero(P%gg) + call SetToZero(P%qq) + call SetToZero(P%gq) + call SetToZero(P%qg) + call SetToZero(P%NS_plus) + call SetToZero(P%NS_minus) + call SetToZero(P%NS_V) + + end subroutine SetToZero_sm + + + !====================================================================== + !! Set the splitting matrix PA to be equal to PB .conv. PC + subroutine SetToConvolution_sm(PA, PB, PC) + type(split_mat), intent(inout) :: PA + type(split_mat), intent(in) :: PB, PC + + PA%nf_int = assert_eq(PB%nf_int, PC%nf_int, 'SetToConvolution_sm') + call cobj_InitSplitLinks(PA) + + call SetToConvolution(PA%singlet , PB%singlet , PC%singlet ) + call SetToConvolution(PA%NS_plus , PB%NS_plus , PC%NS_plus ) + call SetToConvolution(PA%NS_minus, PB%NS_minus, PC%NS_minus) + call SetToConvolution(PA%NS_V , PB%NS_V , PC%NS_V ) + + end subroutine SetToConvolution_sm + + + !---------------------------------------------------------------------- + !! Set the splitting matrix PA to be equal to [PB, PC] + subroutine SetToCommutator_sm(PA, PB, PC) + type(split_mat), intent(inout) :: PA + type(split_mat), intent(in) :: PB, PC + + PA%nf_int = assert_eq(PB%nf_int, PC%nf_int, 'SetToCommutator_sm') + call cobj_InitSplitLinks(PA) + + call SetToCommutator(PA%singlet, PB%singlet, PC%singlet) + ! Recall that following calls also set things to zero + call InitGridConv(PB%NS_plus%grid, PA%NS_plus ) + call InitGridConv(PB%NS_plus%grid, PA%NS_minus) + call InitGridConv(PB%NS_plus%grid, PA%NS_V ) + + end subroutine SetToCommutator_sm + + + !---------------------------------------------------------------------- + !! Clear a splitting function (dealloc memory) + subroutine Delete_sm(P) + type(split_mat), intent(inout) :: P + + call Delete(P%gg); nullify(P%gg) + call Delete(P%qq); nullify(P%qq) + call Delete(P%gq); nullify(P%gq) + call Delete(P%qg); nullify(P%qg) + call Delete(P%NS_plus) + call Delete(P%NS_minus) + call Delete(P%NS_V) + end subroutine Delete_sm + + !---------------------------------------------------------------------- + !! Return the convolution of the splitting matrix P with q_in. + !! + !! If q_in is in the human representation is is returned in the + !! human representation (though internal conversions are carried + !! out). If it is in an evolution representation then it is + !! _assumed_ to be in the representation that corresponds to the nf + !! value of P (and no consistency checking is performed) and no + !! change of representation is carried out. + !! + !! This function also has a 1d overloaded version + function cobj_PConv(P,q_in) result(Pxq) + type(split_mat), intent(in) :: P + real(dp), intent(in), target :: q_in(0:,ncompmin:) + real(dp) :: Pxq(0:ubound(q_in,dim=1),ncompmin:ncompmax) + !-- for when we have to change rep + integer :: pdfr + !type(pdf_rep) :: prep + real(dp), allocatable, target :: q_ev(:,:) + real(dp), pointer :: q(:,:) + integer :: i + + if (ncomponents < P%nf_int) then + call wae_error('cobj_Pconv:',& + &'ncomponents in representation is < nf in P.') + end if + + pdfr = GetPdfRep(q_in) + if (pdfr == pdfr_Evln) then + q => q_in + else + allocate(q_ev(0:ubound(q_in,dim=1),ncompmin:ncompmax)) + !prep = DefaultEvlnRep(p%nf_int) + call CopyHumanPdfToEvln(p%nf_int, q_in, q_ev) + q => q_ev + end if + + PxQ(:, iflv_V) = P%NS_V * q(:,iflv_V) + !PxQ(:, iflv_g) = P%gg * q(:,iflv_g) + P%gq * q(:,iflv_sigma) + !PxQ(:, iflv_sigma) = P%qg * q(:,iflv_g) + P%qq * q(:,iflv_sigma) + PxQ(:,iflv_g:iflv_sigma) = P%singlet .conv. q(:,iflv_g:iflv_sigma) + + !-- we need nf-1 NS (+ and -) pieces + do i = 2, P%nf_int + PxQ(:,+i) = P%NS_plus * q(:,+i) + PxQ(:,-i) = P%NS_minus * q(:,-i) + end do + + !-- everything else should be set to zero + do i = P%nf_int + 1, ncomponents + PxQ(:,+i) = zero + PxQ(:,-i) = zero + end do + + call LabelPdfAsRep(Pxq,pdfr_Evln) + if (pdfr == pdfr_Human) then + q_ev = Pxq ! avoid an extra temporary... (real cleverness might + ! have been to avoid this copy...?) + !call CopyEvlnPdfToHuman(prep, q_ev, Pxq) ! does labelling as well + call CopyEvlnPdfToHuman(p%nf_int, q_ev, Pxq) ! does labelling as well + deallocate(q_ev) + end if + + end function cobj_PConv + + !----------------------------------------------------------------- + !! In some situations the 1d overloaded version is useful. + !! Do just for PConv, but think also about doing it for others + !! later on... + function cobj_PConv_1d(P,q_in) result(Pxq) + type(split_mat), intent(in) :: P + real(dp), intent(in), target :: q_in(0:,ncompmin:,:) + real(dp) :: & + &Pxq(0:ubound(q_in,dim=1),ncompmin:ncompmax,size(q_in,dim=3)) + integer :: i + do i = 1, size(q_in,dim=3) + Pxq(:,:,i) = cobj_PConv(P,q_in(:,:,i)) + end do + end function cobj_PConv_1d + + + + !------------------------------------------------------------ + !! Allocate space for a set of splitting functions, labelling + !! also with the appropriate nf and nloops... + subroutine AllocSplitMat(grid,P,nf_in)!, nloops) + type(grid_def), intent(in) :: grid + type(split_mat), intent(out) :: P + integer, intent(in) :: nf_in + !integer, optional, intent(in) :: nloops + + P%nf_int = nf_in + !P%loops = default_or_opt(0,nloops) + call cobj_InitSplitLinks(P) + call AllocGridConv(grid,P%gg ) + call AllocGridConv(grid,P%qq ) + call AllocGridConv(grid,P%gq ) + call AllocGridConv(grid,P%qg ) + call AllocGridConv(grid,P%NS_plus ) + call AllocGridConv(grid,P%NS_minus) + call AllocGridConv(grid,P%NS_V ) + end subroutine AllocSplitMat + + + !----------------------------------------------------------------- + !! Returns the set of probes needed to establish a matrix of + !! "derived" effective splitting functions. + subroutine GetDerivedSplitMatProbes(grid,probes) + type(grid_def), intent(in) :: grid + real(dp), pointer :: probes(:,:,:) + !----------- + real(dp), pointer :: probes_1d(:,:) + integer :: nprobes, nprobes_1d, iprobe + + call GetDerivedProbes(grid,probes_1d) + + nprobes_1d = ubound(probes_1d,2) + + ! need to double the number of probes because we need to deduce + ! the 2x2 matrix for singlet evolution (so once we'll do it with + ! the singlet quark set to zero; the other time we'll do it with the + ! singlet gluon set to zero). + nprobes = 2*nprobes_1d + + allocate(probes(0:ubound(probes_1d,1),ncompmin:ncompmax, 1:nprobes)) + + probes = zero + do iprobe = 1, nprobes + ! make sure representation is correct... + call LabelPdfAsRep(probes(:,:,iprobe),pdfr_Evln) + end do + + probes(:,iflv_V, 1:nprobes_1d) = probes_1d ! NS_V + probes(:, 2, 1:nprobes_1d) = probes_1d ! NS+ + probes(:, -2, 1:nprobes_1d) = probes_1d ! NS- + probes(:,iflv_sigma, 1:nprobes_1d) = probes_1d ! Quark column of singlet + + ! gluon column of singlet + probes(:,iflv_g, nprobes_1d+1:nprobes) = probes_1d + + ! normally this would be part of housekeeping job of convolution + ! module (SetDerivedConv), but since probes_1d is lost from + ! view at this point, we have to do it ourselves... + deallocate(probes_1d) + end subroutine GetDerivedSplitMatProbes + + + !--------------------------------------------------------------------- + !! Given an allocated split_mat and the results of operating on the probes + !! determine the resulting "derived" splitting function. + subroutine SetDerivedSplitMat(P,probes) + type(split_mat), intent(inout) :: P + real(dp), pointer :: probes(:,:,:) + !----------------------------------------- + integer :: nprobes_1d,nprobes, il, ih + + nprobes = size(probes,dim=3) + nprobes_1d = nprobes/2 + + il = 1; ih = nprobes_1d + call SetDerivedConv_nodealloc(P%NS_V, probes(:,iflv_V,il:ih)) + call SetDerivedConv_nodealloc(P%NS_plus, probes(:,2,il:ih)) + call SetDerivedConv_nodealloc(P%NS_minus, probes(:,-2,il:ih)) + call SetDerivedConv_nodealloc(P%gq, probes(:,iflv_g,il:ih)) + call SetDerivedConv_nodealloc(P%qq, probes(:,iflv_sigma,il:ih)) + + il = nprobes_1d+1; ih = nprobes + call SetDerivedConv_nodealloc(P%gg, probes(:,iflv_g,il:ih)) + call SetDerivedConv_nodealloc(P%qg, probes(:,iflv_sigma,il:ih)) + + deallocate(probes) + end subroutine SetDerivedSplitMat + + !====================================================================== + ! MASS THRESHOLDS + !====================================================================== + ! Here we keep all things to do with mass thresholds + + subroutine InitMTMNNLO(grid,MTM) + type(grid_def), intent(in) :: grid + type(mass_threshold_mat), intent(out) :: MTM + !logical, parameter :: vogt_A2PShg = .false. + !logical, parameter :: vogt_A2PShg = .true. + integer, save :: warn_param = 3 + + call InitGridConv(grid, MTM%PSHq, sf_A2PShq) + select case (nnlo_nfthreshold_variant) + case(nnlo_nfthreshold_param) + call InitGridConv(grid, MTM%PSHg, sf_A2PShg_vogt) + call wae_warn(warn_param,'InitMTMNNLO:& + & using parametrisation (less accuracte) for A2PShg') + case(nnlo_nfthreshold_exact) + call InitGridConv(grid, MTM%PSHg, sf_A2PShg) + case default + call wae_error('InitMTMNNLO', 'Unknown nnlo_threshold_variant',& + &intval=nnlo_nfthreshold_variant) + end select + + call InitGridConv(grid, MTM%NSqq_H, sf_A2NSqq_H) + call InitGridConv(grid, MTM%Sgg_H, sf_A2Sgg_H) + call InitGridConv(grid, MTM%Sgq_H, sf_A2Sgq_H) + ! just store info that it is NNLO. For now it is obvious, but + ! one day when we have NNNLO it may be useful, to indicate + ! which structures exist and which do not. + ! (Mind you inexistent structures have yet to be implemented here...) + MTM%loops = 3 + !-- no default value + MTM%nf_int = 0 + end subroutine InitMTMNNLO + + !--------------------------------------------------------------------- + ! want to be able to set nf, defined as number of flavours + ! after heavy matching + subroutine SetNfMTM(MTM,nf_lcl) + type(mass_threshold_mat), intent(inout) :: MTM + integer, intent(in) :: nf_lcl + if (MTM%loops > 3) then + call wae_Error('SetNfMTM: MTM had loops > 3; nf is probably fixed') + end if + MTM%nf_int = nf_lcl + end subroutine SetNfMTM + + + !---------------------------------------------------------------------- + ! Returns the amount to be added to go from nf-1 to nf flavours. + ! Will try some tests to make sure that nf is consistent? + ! + ! PDFs are assumed to be in "HUMAN" REPRESENTATION. + function cobj_ConvMTM(MTM,q) result(Pxq) + type(mass_threshold_mat), intent(in) :: MTM + real(dp), intent(in) :: q(0:,ncompmin:) + real(dp) :: Pxq(0:ubound(q,dim=1),ncompmin:ncompmax) + real(dp) :: singlet(0:ubound(q,dim=1)) + integer :: i, nf_light, nf_heavy + + !-- general sanity checks + if (MTM%loops <=0 .or. MTM%nf_int <=0) call wae_error('cobj_ConvMTM:',& + &'Mass threshold matrix is undefined') + + if (GetPdfRep(q) /= pdfr_Human) call wae_error('cobj_ConvMTM',& + &'q is not in Human representation') + + nf_heavy = MTM%nf_int + nf_light = nf_heavy - 1 + !write(0,*) 'Doing a MT convolution with nf_heavy =',nf_heavy + + if (ncomponents < nf_heavy) call wae_error('cobj_ConvMTM:',& + &'ncomponents in representation is < nf in MTM.') + if (iflv_g /= 0) call wae_Error('cobj_ConvMTM:','iflv_g/=0') + + !-- sanity check on nf + !if (any(q(:,-nf_heavy)/=zero) .or. any(q(:,nf_heavy)/=zero)) & + ! & call wae_error('cobj_ConvMTM:',& + ! &'Distribution already has non-zero components at nf_heavy') + + singlet = sum(q(:,-nf_light:-1),dim=2) + sum(q(:,1:nf_light),dim=2) + + Pxq(:,nf_heavy) = half*(& + &(MTM%PShq .conv. singlet) + (MTM%PShg .conv. q(:,iflv_g)) ) + Pxq(:,-nf_heavy) = Pxq(:,nf_heavy) + Pxq(:,iflv_g) = (MTM%Sgq_H.conv. singlet) + (MTM%Sgg_H.conv. q(:,iflv_g)) + + do i = -ncomponents, ncomponents + if (abs(i) > nf_heavy) then + Pxq(:,i) = zero + else if (i == iflv_g .or. abs(i) == nf_heavy) then + cycle + else + Pxq(:,i) = MTM%NSqq_H .conv. q(:,i) + end if + end do + + call LabelPdfAsRep(Pxq,pdfr_Human) + end function cobj_ConvMTM + + + !---- usual cleaning up -------------------------------------------- + subroutine cobj_DelMTM(MTM) + type(mass_threshold_mat), intent(inout) :: MTM + call Delete(MTM%PSHq) + call Delete(MTM%PSHg) + call Delete(MTM%NSqq_H) + call Delete(MTM%Sgg_H) + call Delete(MTM%Sgq_H) + MTM%loops = -1 + MTM%nf_int = -1 + end subroutine cobj_DelMTM + + + !====================================================================== + ! From here onwards we have things to do with coefficient functions + subroutine cobj_InitCoeffLO(grid,C, factor) + type(grid_def), intent(in) :: grid + type(coeff_mat), intent(inout) :: C + real(dp), intent(in), optional :: factor + + C%grid = grid + C%HO = .false. + if (present(factor)) then + C%delta = factor + else + C%delta = one + end if + end subroutine cobj_InitCoeffLO + + !-- HO. coeff function is not quite so simple. Note that we do simply + ! call it NLO, because it could also be relevant at O(as^2). + ! NOTE UNUSUAL ORDER... + subroutine cobj_InitCoeffHO(grid, C, coeff_g, coeff_q) + use convolution_communicator + type(grid_def), intent(in) :: grid + type(coeff_mat), intent(inout) :: C + interface + function coeff_g(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: coeff_g + end function coeff_g + end interface + interface + function coeff_q(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: coeff_q + end function coeff_q + end interface + real(dp) :: sanity1, sanity2 + + C%grid = grid + C%HO = .true. + C%delta = zero + call InitGridConv(grid,C%g, coeff_g) + call InitGridConv(grid,C%q, coeff_q) + !-- a sanity check: quite often the arguments for the + ! quark and gluon pieces get exchanged. + ! Cannot always ensure correctness (e.g. FL), but can + ! detect some cases of misuse + cc_piece = cc_VIRT + sanity1 = coeff_g(one) + cc_piece = cc_DELTA + sanity2 = coeff_g(zero) + if (sanity1 /= zero .or. sanity2 /= zero) then + write(0,*) 'WARNING in cobj_InitCoeffHO **********************' + write(0,*) 'gluon coefficient function has virtual corrections' + write(0,*) 'this could be a sign that quark and gluon cf fns have& + & been exchanged' + write(0,*) '**************************************************' + end if + end subroutine cobj_InitCoeffHO + + !-- initialise C as being factor*Cin ---------------------- + subroutine cobj_InitCoeff_cf(C, Cin, factor) + type(coeff_mat), intent(inout) :: C + type(coeff_mat), intent(in) :: Cin + real(dp), intent(in), optional :: factor + + C%grid = Cin%grid + C%HO = Cin%HO + C%delta = Cin%delta + if (present(factor)) C%delta = C%delta * factor + if (C%HO) then + call InitGridConv(C%q, Cin%q, factor) + call InitGridConv(C%g, Cin%g, factor) + end if + end subroutine cobj_InitCoeff_cf + + + !-- initialise C as being factor*Cin ---------------------- + subroutine cobj_AddCoeff(C, Cin, factor) + type(coeff_mat), intent(inout) :: C + type(coeff_mat), intent(in) :: Cin + real(dp), intent(in), optional :: factor + + call ValidateGD(C%grid,Cin%grid,'cobj_AddCoeff') + if (present(factor)) then + C%delta = C%delta + Cin%delta * factor + else + C%delta = C%delta + Cin%delta + end if + + if (Cin%HO) then + if (C%HO) then + call AddWithCoeff(C%q, Cin%q, factor) + call AddWithCoeff(C%g, Cin%g, factor) + else + call InitGridConv(C%q, Cin%q, factor) + call InitGridConv(C%g, Cin%g, factor) + end if + end if + C%HO = C%HO .or. Cin%HO + end subroutine cobj_AddCoeff + + !---------------------------------------------------------------------- + ! Clear a coefficient function (dealloc memory) + subroutine cobj_DelCoeff(C) + type(coeff_mat), intent(inout) :: C + + if (C%HO) then + call Delete(C%g) + call Delete(C%q) + end if + end subroutine cobj_DelCoeff + + + + !------------------------------------------------------------------- + function cobj_CConv(C,q) result(Cxq) + type(coeff_mat), intent(in) :: C + real(dp), intent(in) :: q(0:,0:) + real(dp) :: Cxq(0:ubound(q,dim=1)) + !-------------------------------------------------- + real(dp) :: ud(0:ubound(q,dim=1)) + real(dp), parameter :: uq2 = (4.0_dp/9.0_dp) + real(dp), parameter :: dq2 = (1.0_dp/9.0_dp) + + call wae_error('cobj_CConv:', & + &'coefficient functions not yet suppoprted with new representation') + Cxq = zero + !REPLACE ud = q(:,iflv_u)*uq2 + q(:,iflv_d)*dq2 + !REPLACE if (C%HO) then + !REPLACE !-- CHECK: factor of two in front of nf_u and nf_d is there both + !REPLACE ! in ESW and the ADS paper. + !REPLACE Cxq = (two*(nf_u*uq2 + nf_d*dq2)) * (C%g .conv. q(:,iflv_g))& + !REPLACE & + (C%q .conv. ud) + !REPLACE if (C%delta /= zero) Cxq = Cxq + C%delta * ud + !REPLACE else + !REPLACE Cxq = C%delta * ud + !REPLACE end if + end function cobj_CConv + + !------------------------------------------------------------------- + ! Calculates [(C2 - y^2/(1+(1-y)^2) CL) .conv. pdf] .atx. xbj + ! put it here to have access to .conv. for coefficient functions + function cobj_Eval2LConv(C2, CL, pdf, xbj, ybj) result(res) + use types; use consts_dp; use convolution + type(coeff_mat), intent(in) :: C2, CL + real(dp), intent(in) :: pdf(0:,0:), xbj, ybj + real(dp) :: res + !---------------------------------------------- + type(gdval) :: gdx + type(coeff_mat) :: C2L + + call cobj_InitCoeff(C2L, C2) + call cobj_AddCoeff (C2L, CL, - ybj**2/(1+(1-ybj)**2) ) + gdx = xbj .with. C2%grid + res = EvalGridQuant(gdx%grid, (C2L .conv. pdf), -log(gdx%val)) + !res = ((C2L.conv.pdf) .atx. gdx ) + call cobj_DelCoeff (C2L) + end function cobj_Eval2LConv + +end module dglap_objects +!end module dglap_objects_hidden diff --git a/src/evolution.f90 b/src/evolution.f90 new file mode 100644 index 0000000..c08fea1 --- /dev/null +++ b/src/evolution.f90 @@ -0,0 +1,771 @@ +!====================================================================== +!! +!! Module for providing access to variable-flavour number DGLAP +!! evolution, both directly of a pdf and via evolution operators (with +!! facilities both for setting them and using them). +!! +module evolution + use types; use consts_dp + use dglap_objects; use qcd_coupling + use assertions; use qcd + use warnings_and_errors + implicit none + private + + public :: EvolvePDF, EvolveGeneric + public :: SetDefaultEvolutionDt, SetDefaultEvolutionDu + public :: ev_MSBar2DIS, ev_evolve + public :: DefaultEvolutionDu + + !! + !! A type that allows one to store the result of the evolution as an + !! operator that can be "applied" to any parton distribution, eliminating + !! the need to repeat the whole Runge-Kutta evolution for each new PDF + !! + type evln_operator + type(split_mat) :: P + type(mass_threshold_mat) :: MTM ! assume we have just one of these... + real(dp) :: MTM_coeff, Q_init, Q_end + logical :: cross_mass_threshold + type(evln_operator), pointer :: next + end type evln_operator + public :: evln_operator + public :: InitEvlnOperator + + interface Delete + module procedure Delete_evln_operator + end interface + public :: Delete + + + !! + !! related operation and operator + !! + public :: ev_conv_evop + interface operator(*) + module procedure ev_conv_evop + end interface + public :: operator(*) + interface operator(.conv.) + module procedure ev_conv_evop + end interface + public :: operator(.conv.) + + !! + !! fact that alpha_s/2pi is small means that we can quite comfortably + !! take large steps. Have tested with 0.4 down to 1.5 GeV + !! + !! Originally steps were uniform in dlnQ^2 (dt). As of September 2004, + !! steps are now uniform in d(alpha_s * lnQ^2) = du. They are taken + !! "matched" for alpha_s = 0.25 + !! + real(dp), parameter :: du_dt = 0.25_dp, dt_ballpark_def = 0.4_dp + real(dp) :: dt_ballpark = dt_ballpark_def + real(dp) :: du_ballpark = du_dt * dt_ballpark_def + !real(dp), parameter :: dt_ballpark = 0.2 + + type(split_mat), pointer :: ev_PLO, ev_PNLO, ev_PNNLO + type(running_coupling), pointer :: ev_ash + integer :: ev_nloop + real(dp) :: ev_muR_Q, fourpibeta0_lnmuR_Q + logical :: ev_untie_nf = .false. + + ! this was introduced for testing --- should now never be + ! necessary to set it to .true. + logical, parameter :: ev_force_old_dt = .false. + real(dp), parameter :: ev_minalphadiff = 0.02_dp + integer, parameter :: ev_du_is_dt = 1 + integer, parameter :: ev_du_is_dtas_fixed = 2 + integer, parameter :: ev_du_is_dtas_run = 3 + integer :: ev_du_type + real(dp) :: ev_u_asref, ev_u_tref, ev_u_bval, ev_du_dt + +contains + + + !====================================================================== + !! Set the spacing in t = ln Q^2 for the evolution. Actually this is + !! now out of date, since t is no longer the evolution variable; instead + !! it is a variable u, where du \simeq d(alphas*t). + !! + !! By default du is set to be dt * du_dt, where an effective value + !! of du_dt = 0.25 is used. + subroutine SetDefaultEvolutionDt(dt) + real(dp), intent(in) :: dt + dt_ballpark = dt + du_ballpark = dt * du_dt + end subroutine SetDefaultEvolutionDt + + + !====================================================================== + !! Set the spacing in u \simeq \int dlnQ^2 alphas(Q^2) for evolution + !! steps. + !! + subroutine SetDefaultEvolutionDu(du) + real(dp), intent(in) :: du + dt_ballpark = du / du_dt + du_ballpark = du + end subroutine SetDefaultEvolutionDu + + !====================================================================== + !! Returns du_ballpark + real(dp) function DefaultEvolutionDu() result(res) + res = du_ballpark + end function DefaultEvolutionDu + + + !====================================================================== + !! This serves as a simplified entry point to the EvolveGeneric + !! routine when you just want to evolve a PDF (but don't care about + !! evln_operators). See the EvolveGeneric routine for an explanation + !! of the various options. + !! + subroutine EvolvePDF(dh, pdf, coupling, & + & Q_init, Q_end, muR_Q, nloop, untie_nf) + use dglap_holders; use pdf_representation + type(dglap_holder), intent(in), target :: dh + real(dp), intent(inout) :: pdf(:,:) + type(running_coupling), intent(in), target :: coupling + real(dp), intent(in) :: Q_init, Q_end + real(dp), intent(in), optional :: muR_Q + integer, intent(in), optional :: nloop + logical, intent(in), optional :: untie_nf + + call EvolveGeneric(dh, coupling, Q_init, Q_end, & + & pdf=pdf, muR_Q = muR_Q, nloop = nloop, untie_nf = untie_nf) + end subroutine EvolvePDF + + + !====================================================================== + !! This serves as a simplified entry point to the EvolveGeneric + !! routine when you just want to evolve a PDF (but don't care about + !! evln_operators). See the EvolveGeneric routine for an explanation + !! of the various options. + !! + subroutine InitEvlnOperator(dh, evop, coupling, & + & Q_init, Q_end, muR_Q, nloop, untie_nf) + use dglap_holders; use pdf_representation + type(dglap_holder), intent(in), target :: dh + type(evln_operator), intent(out) :: evop + type(running_coupling), intent(in), target :: coupling + real(dp), intent(in) :: Q_init, Q_end + real(dp), intent(in), optional :: muR_Q + integer, intent(in), optional :: nloop + logical, intent(in), optional :: untie_nf + + call EvolveGeneric(dh, coupling, Q_init, Q_end, & + & evop=evop, muR_Q = muR_Q, nloop = nloop, untie_nf = untie_nf) + end subroutine InitEvlnOperator + + + !====================================================================== + !! A routine that either evolves a PDF from scale Q_init to scale + !! Q_end, or that returns an evln_operator that corresponds to the + !! equivalent evolution. + !! + !! The decision on whether to evolve in a fixed flavour-number + !! scheme (FFNS) are a variable flavour-number scheme (VFNS) is + !! determined from the running coupling object (i.e. the DGLAP + !! evolution does the same thing that was done for the running + !! coupling). + !! + !! If the dglap_holder has been initialised with a smaller nf range + !! than would be needed according to the coupling flavour + !! information, then it is that smaller nf range that is used both + !! for the DGLAP evolution and the coupling; e.g. if dglap_holder is + !! initialised to have 3..5 flavours, then we will have a VFNS with + !! flavours ranging from 3..5, but in the region above the top mass + !! we will resort to a 5-flavour FFNS. + !! + !! Note that this is a potentially inefficient way of getting a + !! mixed VFNS-FFNS (because one has to override the flavour number + !! info in the coupling, involving significant recomputations) -- + !! instead you're better off setting the coupling to have a + !! ficititious large top mass, so that the coupling is naturally in + !! a mixed VFNS-FFNS. + !! + !! dh a holder for dglap, initialised at least up to nloop + !! + !! coupling a running_coupling object + !! + !! Q_init, Q_end: the initial and final scales for the evolution + !! + !! pdf the pdf we evolve + !! + !! evop or the evolution operator we set + !! + !! muR_Q the ratio of the renormalisation scale to the PDF scale + !! + !! nloop specifies the number of loops to be used; by default it + !! is taken equal to the number of loops used in the coupling. + !! + !! untie_nf if (untie_nf) [default false] then alphas is allowed to + !! have its natural value for nf, even if the dglap_holder + !! cannot reach this nf value. + !! + subroutine EvolveGeneric(dh, coupling, Q_init, Q_end, & + & pdf, evop, muR_Q, nloop, untie_nf) + use dglap_holders; use pdf_representation + type(dglap_holder), intent(in), target :: dh + type(running_coupling), intent(in), target :: coupling + real(dp), intent(in) :: Q_init, Q_end + real(dp), intent(inout), optional :: pdf(:,:) + type(evln_operator), intent(inout), optional, target :: evop + real(dp), intent(in), optional :: muR_Q + integer, intent(in), optional :: nloop + logical, intent(in), optional :: untie_nf + !----------------------------------------------------- + !real(dp) :: pdf_ev(size(pdf,dim=1), size(pdf,dim=2)) + type(dglap_holder) :: dhcopy + integer :: nf_init, nf_end, nflcl, nfuse + integer :: shnf_init, shnf_end, direction, i + integer :: nfstore_dhcopy, nfstore_qcd + type(evln_operator), pointer :: this_evop + real(dp), pointer :: probes(:,:,:) + !-- ranges + real(dp) :: QRlo, QRhi, lcl_Q_init, lcl_Q_end + + !-- this will just copy pointers, so that we don't + ! alter info held in original + dhcopy = dh + ! We want to be able to restore things at the end... (not that + ! it is not so much for the dhcopy [which will be deleted] as for + ! the global qcd nf. [maybe we could drop the dhcopy call?] + nfstore_dhcopy = dh%nf + nfstore_qcd = nf_int + + + call ev_SetModuleConsts(coupling, muR_Q, nloop, untie_nf) + + nf_init = NfAtQ(coupling, Q_init, muM_mQ=one) + nf_end = NfAtQ(coupling, Q_end, muM_mQ=one) + + !write(0,*) real(Q_init), real(Q_end), nf_init, nf_end + + !-- could use sign, but cannot remember subtleties of signed + ! zeroes in f95, and do not have manual at hand... + if (Q_end >= Q_init) then + direction = 1 + else + direction = -1 + end if + + call ev_limit_nf(dhcopy, nf_init, shnf_init,'initial nf') + call ev_limit_nf(dhcopy, nf_end , shnf_end ,'final nf') + + + ! in loop we may want to refer to subsequent elements in chain, + ! so make use of a pointer which is kept updated + if (present(evop)) then + this_evop => evop + else + nullify(this_evop) + end if + + do nflcl = shnf_init, shnf_end, direction + call QRangeAtNf(coupling,nflcl,QRlo,QRhi, muM_mQ=one) + if (direction == 1) then + lcl_Q_init = max(Q_init, QRlo) + lcl_Q_end = min(Q_end, QRhi) + else + lcl_Q_init = min(Q_init, QRhi) + lcl_Q_end = max(Q_end, QRlo) + end if + ! make sure that end points are correct... + if (nflcl == shnf_init) lcl_Q_init = Q_init + if (nflcl == shnf_end) lcl_Q_end = Q_end + !-- this will also set the global (qcd) nf_int which will + ! be used elsewhere in this module + call SetNfDglapHolder(dhcopy, nflcl) + + ! convention: cross mass thresholds before a step in the evolution + if (nflcl /= shnf_init) then + ! act directly + if (present(pdf))& + & call ev_CrossMassThreshold(dhcopy,coupling,direction,pdf) + ! or store the information that will be needed to act subsequently. + if (present(evop)) call ev_CrossMassThreshold(dhcopy,& + & coupling,direction,evop=this_evop) + else if (present(evop)) then + this_evop%cross_mass_threshold = .false. + end if + + ! do evolution + if (present(pdf)) call ev_evolve(dhcopy, & + &pdf, coupling, lcl_Q_init, lcl_Q_end, muR_Q, nloop, untie_nf) + + ! do the fake evolutions that allow us to do an accelerated + ! evolution later on. + if (present(evop)) then + ! recall: memory management of probes is done automatically + call GetDerivedSplitMatProbes(dh%grid,probes) + do i = 1, size(probes,3) + call ev_evolve(dhcopy, & + &probes(:,:,i), coupling, lcl_Q_init,lcl_Q_end, muR_Q, nloop) + end do + call AllocSplitMat(dh%grid, this_evop%P, nflcl) + call SetDerivedSplitMat(this_evop%P,probes) + if (nflcl == shnf_end) then + nullify(this_evop%next) + else + allocate(this_evop%next) + this_evop => this_evop%next + end if + end if + end do + + !-- clean up + call SetNfDglapHolder(dhcopy, nfstore_dhcopy) + if (nfstore_qcd /= nfstore_dhcopy) call qcd_SetNf(nfstore_qcd) + end subroutine EvolveGeneric + + + !====================================================================== + !! Cross the mass threshold in the specified direction (+-1). It is + !! assumed that the current (module qcd) nf_int value corrresponds + !! to the number of flavours _after_ crossing the threshold. + !! + !! Currently only supports mass thresholds at muF = m_H. + !! + !! Currently direction = -1 is not supported at NNLO -- this needs + !! to be sorted out, with special care about temporarily resetting + !! the number of active flavours so that it corresponds to the + !! number above threshold, rather than the number after crossing the + !! threshold. + !! + subroutine ev_CrossMassThreshold(dh,coupling,direction,pdf,evop) + use dglap_holders; use pdf_representation; use dglap_choices + type(dglap_holder), intent(inout) :: dh + type(running_coupling), intent(in) :: coupling + integer, intent(in) :: direction + real(dp), intent(inout), optional :: pdf(:,:) + type(evln_operator), intent(inout), optional :: evop + !---------------------------------------------- + integer, save :: warn_DIS = 2, warn_Direction = 2 + real(dp) :: as2pi, muR + integer :: nfstore + + !-- CHANGE THIS IF HAVE MATCHING AT MUF/=MH + if (ev_nloop < 3) return + if (.not. mass_steps_on) return + if (dh%factscheme /= factscheme_MSBar) then + call wae_Warn(warn_DIS,& + &'ev_CrossMassThreshold',& + &'Factscheme is not MSBar;& + & mass thresholds requested but not implemented') + return + end if + + nfstore = nf_int ! keep record in case we change it + select case(direction) + case(1) + case(-1) + ! nf value is that after crossing threshold; but for MTM + ! (and other things) we need nf value above threshold, i.e. before + ! crossing the threshold; so put in the correct value temporarily + call SetNfDglapHolder(dh, nfstore + 1) + case default + call wae_error('ev_CrossMassThreshold',& + & 'direction had unsupported value of',intval=direction) + end select + + !if (direction /= 1) then + ! call wae_Warn(max_warn,warn_Direction,& + ! &'ev_CrossMassThreshold',& + ! &'Direction/=1; mass thresholds requested but not implemented') + ! return + !end if + + !-- now actually do something! + !muR = quark_masses(nf_int) * ev_MuR_Q + muR = QuarkMass(coupling,nf_int) * ev_MuR_Q + !write(0,*) 'evolution crossing threshold ', nf_int, muR + + !-- fix nf so as to be sure of getting alpha value corresponding + ! to the desired nf value, despite proximity to threshold. + as2pi = Value(coupling, muR, fixnf=nf_int) / twopi + if (present(pdf)) pdf = pdf + & + & (direction*as2pi**2) * (dh%MTM2 .conv. pdf) + if (present(evop)) then + evop%cross_mass_threshold = .true. + evop%MTM = dh%MTM2 ! stores current nf value + evop%MTM_coeff = (direction*as2pi**2) + end if + + if (nf_int /= nfstore) call SetNfDglapHolder(dh, nfstore) + + end subroutine ev_CrossMassThreshold + + + !====================================================================== + !! Return the action of the evln_operator on the pdfdist + function ev_conv_evop(evop,pdfdist) result(res) + type(evln_operator), intent(in), target :: evop + real(dp), intent(in) :: pdfdist(:,:) + real(dp) :: res(size(pdfdist,dim=1),size(pdfdist,dim=2)) + !------------ + type(evln_operator), pointer :: this_evop + + this_evop => evop + res = pdfdist + do + if (this_evop%cross_mass_threshold) then + ! NB: this never eccurs on first pass + res = res + this_evop%MTM_coeff * (this_evop%MTM .conv. res) + end if + + res = this_evop%P .conv. res + + if (associated(this_evop%next)) then + this_evop => this_evop%next + else + return + end if + end do + end function ev_conv_evop + + + + !====================================================================== + !! Return dhnflcl, which is nflcl modified to as to be + !! within the supported limits of dh. + !! + !! Thus we can evolve with 5 flavours even into the + !! 6 flavour region, without the whole house crashing down + !! + !! Beware that this sort of thing is dangerous, because + !! alphas might have one value for nf, beta0 a different value, + !! and overall ca sera la pagaille (if the untie_nf option is .true.) + subroutine ev_limit_nf(dh, nflcl, dhnflcl, nfname) + use dglap_holders + type(dglap_holder), intent(in) :: dh + integer, intent(in) :: nflcl + integer, intent(out) :: dhnflcl + character(len=*), intent(in) :: nfname + !---------------------------------------- + integer, parameter :: max_warn = 4 + integer :: warn_id = warn_id_INIT + integer :: nflo, nfhi + character(len=80) :: nfstring + + nflo = lbound(dh%allP,dim=2) + nfhi = ubound(dh%allP,dim=2) + + dhnflcl = max(min(nflcl,nfhi),nflo) + + if (nflcl /= dhnflcl) then + write(nfstring,'(a,i1,a,i1,a)') " changed from ",nflcl," to ",& + &dhnflcl,"." + call wae_warn(max_warn, warn_id, 'ev_limit_nf: '//& + &nfname//trim(nfstring)) + end if + end subroutine ev_limit_nf + + + + !====================================================================== + !! Internal entry routine for evolution with a fixed number of + !! flavours. Takes a human distribution and deals with the necessary + !! conversion to and from "evolution" format. The evolution order + !! is set by nloop. + subroutine ev_evolve(dh, pdf, coupling, Q_init, Q_end, muR_Q,& + & nloop, untie_nf) + use dglap_holders; use pdf_representation + type(dglap_holder), intent(in), target :: dh + real(dp), intent(inout) :: pdf(iflv_min:,0:) + type(running_coupling), intent(in), target :: coupling + real(dp), intent(in) :: Q_init, Q_end + real(dp), intent(in), optional :: muR_Q + integer, intent(in), optional :: nloop + logical, intent(in), optional :: untie_nf + !----------------------------------------------------- + real(dp) :: pdf_ev(size(pdf,dim=1), size(pdf,dim=2)) + integer :: pdfrep + + !-- make sure that number of flavours is correct? + !if (nf_int /= dh%prep%nf) call wae_error('ev_evolve: & + if (nf_int /= dh%nf) call wae_error('ev_evolve: & + &global nf and representation nf are not equal.') + + !-- put things into the right format just once (it would + ! be done automatically by the conv_object routines, but + ! that would be wasteful) + pdfrep = GetPdfRep(pdf) + if (pdfrep == pdfr_Human) then + !call CopyHumanPdfToEvln(dh%prep, pdf, pdf_ev) + call CopyHumanPdfToEvln(dh%nf, pdf, pdf_ev) + else + pdf_ev = pdf + end if + + ev_ash => coupling + call ev_SetModuleConsts(coupling, muR_Q, nloop, untie_nf) + + if (ev_nloop > dh%nloop) & + &call wae_error('ev_evolve: dh%nloop must be >= nloop') + + ev_PLO => dh%P_LO + if (ev_nloop >= 2) ev_PNLO => dh%P_NLO + if (ev_nloop >= 3) ev_PNNLO => dh%P_NNLO + + + call ev_evolveLocal(pdf_ev, Q_init, Q_end) + + !-- put things back into a "human" format + if (pdfrep == pdfr_Human) then + !call CopyEvlnPdfToHuman(dh%prep, pdf_ev, pdf) + call CopyEvlnPdfToHuman(dh%nf, pdf_ev, pdf) + else + pdf = pdf_ev + end if + end subroutine ev_evolve + + + !--------------------------------------------------------- + !! A shortcut for setting up copies of information + !! which may be useful module-wide + !! + !! Is it really needed? + subroutine ev_SetModuleConsts(coupling, muR_Q, nloop, untie_nf) + type(running_coupling), intent(in) :: coupling + real(dp), intent(in), optional :: muR_Q + integer, intent(in), optional :: nloop + logical, intent(in), optional :: untie_nf + + ev_nloop = default_or_opt(NumberOfLoops(coupling),nloop) + ev_muR_Q = default_or_opt(one,muR_Q) + ev_untie_nf = default_or_opt(.false., untie_nf) + end subroutine ev_SetModuleConsts + + + + !====================================================================== + !! Takes pdf in the MSBar scheme and converts it into the DIS scheme, + !! hopefully correctly! + subroutine ev_MSBar2DIS(dh,pdf,coupling,Q,nloop) + use dglap_holders; use pdf_representation; use convolution + type(dglap_holder), intent(in) :: dh + real(dp), intent(inout) :: pdf(:,:) + type(running_coupling), intent(in), target :: coupling + real(dp), intent(in) :: Q + integer, intent(in), optional :: nloop + !----------------------------------------------------- + real(dp) :: pdf_ev(size(pdf,dim=1), -ncomponents:ncomponents ) + real(dp) :: Cq_x_q(size(pdf,dim=1)), Cg_x_g(size(pdf,dim=1)) + real(dp) :: as2pi + integer :: id + + !-- put things into the right format + !call CopyHumanPdfToEvln(dh%prep, pdf, pdf_ev) + call CopyHumanPdfToEvln(dh%nf, pdf, pdf_ev) + + as2pi = Value(coupling,Q) / twopi + ev_nloop = default_or_opt(NumberOfLoops(coupling),nloop) + + if (ev_nloop /= 2) call wae_error('ev_MSBar2DIS',& + & 'number of loops was not=2 [currently only case supported]') + + Cq_x_q = as2pi * (dh%C2_1%q .conv. pdf_ev(:,iflv_sigma)) + !Cg_x_g = (2*dh%prep%nf * as2pi) * (dh%C2_1%g .conv. pdf_ev(:,iflv_g)) + Cg_x_g = (2*dh%nf * as2pi) * (dh%C2_1%g .conv. pdf_ev(:,iflv_g)) + + pdf_ev(:,iflv_sigma) = pdf_ev(:,iflv_sigma) + Cq_x_q + Cg_x_g + pdf_ev(:,iflv_g) = pdf_ev(:,iflv_g) - Cq_x_q - Cg_x_g + + !do id = -dh%prep%nf, dh%prep%nf + do id = -dh%nf, dh%nf + if (id == iflv_sigma .or. id == iflv_g) cycle + pdf_ev(:,id) = pdf_ev(:,id) + as2pi * (dh%C2_1%q .conv. pdf_ev(:,id)) + end do + + !-- put things back into a "human" format + !call CopyEvlnPdfToHuman(dh%prep, pdf_ev, pdf) + call CopyEvlnPdfToHuman(dh%nf, pdf_ev, pdf) + !write(0,*) 'hello', lbound(pdf), lbound + + end subroutine ev_MSBar2DIS + + + + + !====================================================================== + !! this bit here does the actual evolution of a PDF. Could make it + !! more sophisticated later, if necessary (e.g. variable step size). + subroutine ev_evolveLocal(pdf, Q_init, Q_end) + use runge_kutta + real(dp), intent(inout) :: pdf(:,:) + real(dp), intent(in) :: Q_init, Q_end + !------------------------------------------------------------ + real(dp) :: t1, t2, dt, t, u1, u2, du, u, as1, as2 + integer :: n, i + integer :: ntot=0 + + fourpibeta0_lnmuR_Q = four*pi*beta0*log(ev_muR_Q) + !write(0,*) fourpibeta0_lnmuR_Q + t1 = two*log(Q_init) + t2 = two*log(Q_end) + + if (t2 == t1) return + + !-- now work out jacobians... + as1 = ev_asval(Q_init) + as2 = ev_asval(Q_end) + + ! allow for both signs of coupling (and sign changes) + ! See CCN25-95 for formulae (NB: 0->1 and 1->2) + if (ev_force_old_dt) then + ev_du_type = ev_du_is_dt + u1 = t1; u2 = t2 + n = ceiling(abs(t2-t1)/dt_ballpark) + else if (abs(as1 - as2)/max(as1,as2) < ev_minalphadiff & + &.or. as1*as2 <= zero) then + !else if (.true.) then + ev_du_type = ev_du_is_dtas_fixed + ev_du_dt = max(abs(as1),abs(as2)) + u1 = t1 * ev_du_dt; u2 = t2 * ev_du_dt + n = ceiling(abs(u2-u1)/du_ballpark) + else + ev_du_type = ev_du_is_dtas_run + ev_u_asref = as1 + ev_u_tref = t1 + ev_u_bval = (as1/as2-1)/(as1*(t2-t1)) + u1 = zero + u2 = log(1+ev_u_bval*ev_u_asref*(t2-t1)) / ev_u_bval + n = ceiling(abs(u2-u1)/du_ballpark) + !write(0,*) ev_u_asref, ev_u_bval + end if + + !n = ceiling(abs(t2-t1)/dt_ballpark) + !dt = (t2 - t1)/n + du = (u2 - u1)/n + + ntot = ntot + n + !write(0,*) 'Qinit,end, nsteps', Q_init, Q_end, n, ntot + u = u1 + do i = 1, n + call rkstp(du, u, pdf, ev_conv) + end do + end subroutine ev_evolveLocal + + + !====================================================================== + !! Assuming the relevant module-wide variables have been set, this + !! returns the derivative dpdf (wrt "u" -- defined precisely + !! elsewhere) of pdf, as specified by the DGLAP equations. + !! + subroutine ev_conv(u, pdf, dpdf) + use pdf_representation + ! The following fails with absoft compiler: see ABSOFT_BUG.txt + real(dp), intent(in) :: u, pdf(:,:) + real(dp), intent(out) :: dpdf(:,:) + ! The following fails with the intel compiler! See INTEL_BUG.txt + !real(dp), intent(in) :: t, pdf(0:,-ncomponents:) + !real(dp), intent(out) :: dpdf(0:,-ncomponents:) + !-------------------------------------- + real(dp) :: as2pi, Q, t, jacobian + type(split_mat) :: Pfull + + ! for analysing Intel bug + !write(0,*) 'X',lbound(pdf),lbound(pdf,dim=1),size(pdf,dim=1) + + select case(ev_du_type) + case(ev_du_is_dt) + t = u + jacobian = one + case(ev_du_is_dtas_fixed) + t = u / ev_du_dt + jacobian = one / ev_du_dt + case(ev_du_is_dtas_run) + t = ev_u_tref + (exp(ev_u_bval*u)-one)/(ev_u_bval*ev_u_asref) + jacobian = (1+ev_u_bval*ev_u_asref*(t-ev_u_tref))/ev_u_asref + case default + call wae_error('evconv: unknown ev_du_type',intval=ev_du_type) + end select + + Q = exp(half*t) + as2pi = ev_asval(Q)/twopi + + select case (ev_nloop) + case(1) + dpdf = (jacobian * as2pi) * (ev_PLO .conv. pdf) + case(2) + if (fourpibeta0_lnmuR_Q /= zero) then + call InitSplitMat(Pfull, ev_PLO, one + as2pi*fourpibeta0_lnmuR_Q) + else + call InitSplitMat(Pfull, ev_PLO) + end if + call AddWithCoeff(Pfull, ev_PNLO, as2pi) + dpdf = (jacobian * as2pi) * (Pfull .conv. pdf) + call Delete(Pfull) + case(3) + if (fourpibeta0_lnmuR_Q /= zero) then + call InitSplitMat(Pfull, ev_PLO, one + as2pi*fourpibeta0_lnmuR_Q& + & + (as2pi*fourpibeta0_lnmuR_Q)**2& + & + as2pi**2*(twopi**2*beta1)*two*log(ev_muR_Q)) + call AddWithCoeff(Pfull, ev_PNLO, & + &as2pi*(one + two*as2pi*fourpibeta0_lnmuR_Q)) + call AddWithCoeff(Pfull, ev_PNNLO, as2pi**2) + !call wae_error('ev_conv: NNL evolution not supported with muR_Q/=1') + else + call InitSplitMat(Pfull, ev_PLO) + call AddWithCoeff(Pfull, ev_PNLO, as2pi) + call AddWithCoeff(Pfull, ev_PNNLO, as2pi**2) + end if + dpdf = (jacobian * as2pi) * (Pfull .conv. pdf) + call Delete(Pfull) + end select + end subroutine ev_conv + + + !====================================================================== + !! Given module-wide variables (including a pointer to the running + !! coupling object), this returns alphas for the appropriate number + !! of flavours and at a scale Q*muR_Q. + !! + !! (put there because nf handling and xmuR handling involve various + !! options, and it is convenient to have a common call that handles + !! all options correctly). + function ev_asval(Q) result(res) + real(dp), intent(in) :: Q + real(dp) :: res + if (.not. ev_untie_nf) then + !-- fixnf option here will be quite restrictive. It means that + ! if we have ev_muR_Q/=1 and variable numbers of flavours, + ! then either ev_ash supports "extrapolation" with the same nf + ! beyond the strictly legal region, or else it has been defined + ! so as to have flavour thresholds at ev_muR_Q*masses + res = Value(ev_ash, Q*ev_muR_Q, fixnf=nf_int) + else + ! sometimes (e.g. comparisons with others) it is useful to + ! allow nf in alpha_s to have a value different from the nf + ! being used in the splitting functions... + res = Value(ev_ash, Q*ev_muR_Q) + end if + + end function ev_asval + + + !====================================================================== + !! Delete the objects allocated in evop, including any + !! subsiduary objects. + recursive subroutine Delete_evln_operator(evop) + type(evln_operator), intent(inout) :: evop + + if (associated(evop%next)) then + call Delete_evln_operator(evop%next) + deallocate(evop%next) + end if + + ! do nothing here since MTM has not actually been allocated + ! but rather just set "equal" to dh%MTM2 -- i.e. it just points + ! to the contents of dh%MTM2 (except for the nf info, which is + ! local, but does not need dealocating) + !if (evop%cross_mass_threshold) then ! do nothing + + call Delete(evop%P) + return + end subroutine Delete_evln_operator + + +end module evolution + diff --git a/src/f77_pdftab.f90 b/src/f77_pdftab.f90 new file mode 100644 index 0000000..72cc133 --- /dev/null +++ b/src/f77_pdftab.f90 @@ -0,0 +1,153 @@ +module f77_pdftab + use types; use consts_dp + use pdf_tabulate_new + use convolution; use pdf_general; use dglap_objects + use dglap_holders; use pdf_general; use dglap_choices + implicit none + + !! holds information about the grid + type(grid_def), save :: grid, gdarray(3) + + !! holds the splitting functions + type(dglap_holder), save :: dh + + !! 0 is main pdf table, while i=1:3 contain convolutions with the + !! i-loop splitting function + type(pdftab), save :: tables(0:3) + logical, save :: setup_done(0:3) = .false. + integer, save :: setup_nf(3) = 0 +end module f77_pdftab + + +!====================================================================== +!! initialise the underlying grid, splitting functions and pdf-table +!! objects, using the dy and nloop parameters as explained below. +subroutine dglapStart(dy,nloop) + use f77_pdftab + implicit none + real(dp), intent(in) :: dy !! internal grid spacing: 0.1 is a sensible value + integer, intent(in) :: nloop !! the maximum number of loops we'll want (<=3) + !------------------------------------- + real(dp) :: ymax + integer :: order + + ! initialise our grids + ! specify the maximum value of log(1/x) + ymax = 12.0_dp + ! the internal interpolation order (with a minus sign allows + ! interpolation to take fake zero points beyond x=1 -- convolution + ! times are unchanged, initialisation time is much reduced and + ! accuracy is slightly reduced) + order = -5 + ! Now create a nested grid + call InitGridDef(gdarray(3),dy/9.0_dp,0.5_dp, order=order) + call InitGridDef(gdarray(2),dy/3.0_dp,2.0_dp, order=order) + call InitGridDef(gdarray(1),dy, ymax ,order=order) + call InitGridDef(grid,gdarray(1:3),locked=.true.) + + ! create the tables that will contain our copy of the user's pdf + ! as well as the convolutions with the pdf. + call pdftab_AllocTab(grid, tables(:), Qmin=1.0_dp, Qmax=28000.0_dp, & + & dlnlnQ = min(dy,0.1_dp), freeze_at_Qmin=.true.) + + ! initialise splitting-function holder + call InitDglapHolder(grid,dh,factscheme=factscheme_MSbar,& + & nloop=nloop,nflo=3,nfhi=6) + ! choose a sensible default number of flavours. + call SetNfDglapHolder(dh,nflcl=5) + + ! indicate the pdfs and convolutions have not been initialised... + setup_done = .false. +end subroutine dglapStart + + +!====================================================================== +!! Given a pdf_subroutine with the interface shown below, initialise +!! our internal pdf table. +subroutine dglapAssign(pdf_subroutine) + use f77_pdftab ! this module which provides access to the array of tables + implicit none + interface ! indicate what "interface" pdf_subroutine is expected to have + subroutine pdf_subroutine(x,Q,res) + use types; implicit none + real(dp), intent(in) :: x,Q + real(dp), intent(out) :: res(*) + end subroutine pdf_subroutine + end interface + !----------------------------------- + + ! set up table(0) by copying the values returned by pdf_subroutine onto + ! the x-Q grid in table(0) + call pdftab_InitTab_LHAPDF(tables(0), pdf_subroutine) + ! indicate that table(0) has been set up + setup_done(0) = .true. + ! indicate that table(1), table(2), etc... (which will contain the + ! convolutions with splitting matrices) have yet to be set up [they + ! get set up "on demand" later]. + setup_done(1:) = .false. +end subroutine dglapAssign + + +!====================================================================== +!! Return in f(-6:6) the value of the internally stored pdf at the +!! given x,Q, with the usual LHApdf meanings for the indices -6:6. +subroutine dglapEval(x,Q,f) + use f77_pdftab + implicit none + real(dp), intent(in) :: x, Q + real(dp), intent(out) :: f(-6:6) + + call pdftab_ValTab_xQ(tables(0),x,Q,f) +end subroutine dglapEval + + + +!====================================================================== +!! Return in f(-6:6) the value of +!! +!! [P(iloop,nf) \otimes pdf] (x,Q) +!! +!! where P(iloop,nf) is the iloop-splitting function for the given +!! value of nf, and pdf is our internally stored pdf. +!! +!! The normalisation is such that the nloop dglap evolution equation is +!! +!! dpdf/dlnQ^2 = sum_{iloop=1}^nloop +!! (alphas/(2*pi))^iloop * P(iloop,nf) \otimes pdf +!! +!! Note that each time nf changes relative to a previous call for the +!! same iloop, the convolution has to be repeated for the whole +!! table. So for efficient results when requiring multiple nf values, +!! calls with the same nf value should be grouped together. +!! +!! In particular, for repeated calls with the same value of nf, the +!! convolutions are carried out only on the first call (i.e. once for +!! each value of iloop). Multiple calls with different values for +!! iloop can be carried out without problems. +!! +subroutine dglapEvalSplit(x,Q,iloop,nf,f) + use f77_pdftab; use warnings_and_errors + implicit none + real(dp), intent(in) :: x, Q + integer, intent(in) :: iloop, nf + real(dp), intent(out) :: f(-6:6) + + if (.not. setup_done(iloop) .or. setup_nf(iloop) /= nf) then + if (iloop > size(dh%allP,dim=1) .or. iloop < 1) & + &call wae_error('dglapeval_split','illegal value for iloop:',& + &intval=iloop) + + if (nf < lbound(dh%allP,dim=2) .or. nf > ubound(dh%allP,dim=2)) & + &call wae_error('dglapeval_split','illegal value for nf:',& + &intval=nf) + + tables(iloop)%tab = dh%allP(iloop, nf) .conv. tables(0)%tab + + setup_done(iloop) = .true. + setup_nf(iloop) = nf + end if + + call pdftab_ValTab_xQ(tables(iloop),x,Q,f) +end subroutine dglapEvalSplit + + diff --git a/src/hoppet_v1.f90 b/src/hoppet_v1.f90 new file mode 100644 index 0000000..ee685c2 --- /dev/null +++ b/src/hoppet_v1.f90 @@ -0,0 +1,12 @@ +module hoppet_v1 + use types; use consts_dp + use convolution; use dglap_objects + use pdf_representation; use pdf_general + use dglap_choices + use warnings_and_errors + use dglap_holders + use evolution + use qcd_coupling + use pdf_tabulate_new + implicit none +end module hoppet_v1 diff --git a/src/hplog.f b/src/hplog.f new file mode 100644 index 0000000..563a297 --- /dev/null +++ b/src/hplog.f @@ -0,0 +1,3271 @@ +****************************************************************************** +** hplog: a subroutine for the evaluation of harmonic polylogarithms +** Version 1.0 12/07/2001 +** described in: +** T.Gehrmann and E.Remiddi: Numerical Evaluation of the Harmonic +** Polylogarithms up to Weight 4 +** (hep-ph/0107173; CERN-TH/2001/188) +** the harmonic polylogarithms are defined in: +** E.Remiddi and J.Vermaseren: Harmonic Polylogarithms +** (hep-ph/9905237; Int.J.Mod.Phys. A15 (2000) 725) +** email: +** Thomas.Gehrmann@cern.ch and Ettore.Remiddi@bo.infn.it +** +****************************************************************************** + subroutine hplog(x,nw,Hc1,Hc2,Hc3,Hc4, + $ Hr1,Hr2,Hr3,Hr4,Hi1,Hi2,Hi3,Hi4,n1,n2) +****** +** x is the argument of the 1dHPL's (1 dimensional Harmonic PolyLogarithms) +** to be evaluated; +** nw is the maximum weight of the required 1dHPL's; +** the maximum allowed value of nw of this implementation is 4; +** Hc1,Hc2,Hc3,Hc4 are the complex*16 values of the 1dHPL; +** they must all be supplied in the arguments even if some of them +** are not to be evaluated; +** Hr1,Hr2,Hr3,Hr4 are the double precision real parts of +** Hc1,Hc2,Hc3,Hc4; +** Hi1,Hi2,Hi3,Hi4 are the double precision immaginary parts of +** Hc1,Hc2,Hc3,Hc4 divided by pi=3.114159.... +** n1,n2 is the required range of indices, the allowed ranges are +** (0,1), (-1,0), (-1,1) ; +****** + implicit double precision (a-h,o-z) + complex*16 Hc1,Hc2,Hc3,Hc4 + dimension Hc1(n1:n2),Hc2(n1:n2,n1:n2),Hc3(n1:n2,n1:n2,n1:n2), + $ Hc4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hr1(n1:n2),Hr2(n1:n2,n1:n2),Hr3(n1:n2,n1:n2,n1:n2), + $ Hr4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) + common /fillred/infilldim,infill(3) + parameter (r2 = 1.4142135623730950488d0) +** check on the weight nw + if ( (nw.lt.1).or.(nw.gt.4) ) then + print*, ' illegal call of eval1dhpl with second argument', + $ ' (the weight) = ',nw + print*, ' the allowed values of the weight are 1,2,3,4 ' + stop + endif +** check on the range n1:n2 + if ( (n1.eq.-1).and.(n2.eq.0) ) then + infilldim = 2 + infill(1) = 0 + infill(2) = -1 + elseif ( (n1.eq.0).and.(n2.eq.1) ) then + infilldim = 2 + infill(1) = 0 + infill(2) = 1 + elseif ( (n1.eq.-1).and.(n2.eq.1) ) then + infilldim = 3 + infill(1) = 0 + infill(2) = -1 + infill(3) = 1 + else + print*, ' illegal call of eval1dhpl with the two last ', + $ 'arguments = (',n1,',',n2,')' + print*, ' the allowed values are (-1,0), (0,1), (-1,1) ' + stop + endif +** setting the immaginary parts equal to zero + call setzero(nw,Hi1,Hi2,Hi3,Hi4,n1,n2) +** looking at the range of the argument +* r2 = sqrt(2.d0) + r2m1 = r2 - 1 + r2p1 = r2 + 1 + if ( ( x.gt.-r2m1 ).and.( x.le.r2m1) ) then +* print*, ' eval1dhpl: x = ',x,', call eval1dhplat0 ' + call eval1dhplat0(x,nw,Hc1,Hc2,Hc3,Hc4, + $ Hr1,Hr2,Hr3,Hr4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + elseif ( x.eq.1d0 ) then +* print*, ' eval1dhpl: x = ',x,', call eval1dhplin1 ' + call eval1dhplin1(x,nw,Hc1,Hc2,Hc3,Hc4, + $ Hr1,Hr2,Hr3,Hr4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + elseif ( ( x.gt.r2m1 ).and.( x.le.r2p1) ) then +* print*, ' eval1dhpl: x = ',x,', call eval1dhplat1 ' + call eval1dhplat1(x,nw,Hc1,Hc2,Hc3,Hc4, + $ Hr1,Hr2,Hr3,Hr4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + elseif ( ( x.gt.r2p1 ) ) then +* print*, ' eval1dhpl: x = ',x,', call eval1dhplatinf ' + call eval1dhplatinf(x,nw,Hc1,Hc2,Hc3,Hc4, + $ Hr1,Hr2,Hr3,Hr4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + elseif ( ( x.le.-r2p1) ) then +* print*, ' eval1dhpl: x = ',x,', call eval1dhplatminf ' + call eval1dhplatminf(x,nw,Hc1,Hc2,Hc3,Hc4, + $ Hr1,Hr2,Hr3,Hr4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + elseif ( x.eq.-1d0 ) then +* print*, ' eval1dhpl: x = ',x,', call eval1dhplinm1 ' + call eval1dhplinm1(x,nw,Hc1,Hc2,Hc3,Hc4, + $ Hr1,Hr2,Hr3,Hr4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + elseif ( ( x.gt.-r2p1 ).and.( x.le.-r2m1) ) then +* print*, ' eval1dhpl: x = ',x,', call eval1dhplatm1 ' + call eval1dhplatm1(x,nw,Hc1,Hc2,Hc3,Hc4, + $ Hr1,Hr2,Hr3,Hr4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + endif +** + end +************************************************************************ + subroutine eval1dhplat0(y,nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates 1dhpl's in the 0-range -(r2-1) < y <= (r2-1) +** by direct series expansion (Bernoulli-accelerated) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + dimension H1(n1:n2),H2(n1:n2,n1:n2),H3(n1:n2,n1:n2,n1:n2), + $ H4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) +** evaluate the irreducible 1dHPL's first + call fillh1(y,H1,HY1,Hi1,n1,n2) + if ( nw.eq.1 ) return + call fillirr1dhplat0(y,nw,HY1,HY2,HY3,HY4,n1,n2) +** then the reducible 1dHPL's + call fillred1dhpl(nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + end +************************************************************************ + subroutine eval1dhplin1(y,nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates 1dhpl's for y=1 (explicit values are tabulated) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + dimension H1(n1:n2),H2(n1:n2,n1:n2),H3(n1:n2,n1:n2,n1:n2), + $ H4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) + parameter (pi = 3.14159265358979324d0) +** evaluate the irreducible 1dHPL's first + call fillh1(y,H1,HY1,Hi1,n1,n2) + if ( nw.eq.1 ) return + call fillirr1dhplin1(y,nw,HY1,HY2,HY3,HY4,n1,n2) +** then the reducible 1dHPL's + call fillred1dhpl(nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) + if (n2.eq.0) return +** correct the ill-defined entries + HY2(1,0) = - HY2(0,1) + Hi2(1,0) = 0d0 + H2(1,0) = dcmplx(HY2(1,0),Hi2(1,0)*pi) + if ( nw.eq.2 ) return + HY3(1,0,0) = HY3(0,0,1) + Hi3(1,0,0) = 0d0 + H3(1,0,0) = dcmplx(HY3(1,0,0),Hi3(1,0,0)*pi) + if ( nw.eq.3 ) return + HY4(1,0,0,0) = -HY4(0,0,0,1) + Hi4(1,0,0,0) = 0d0 + H4(1,0,0,0) = dcmplx(HY4(1,0,0,0),Hi4(1,0,0,0)*pi) + return + end +************************************************************************ + subroutine eval1dhplat1(y,nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates 1dhpl's in the 1-range (r2-1) < y <= (r2+1) +** evaluating first the H(..,r=(1-y)/(1+y)) by calling eval1dhplat0(r) +** and then expressing H(..,y=(1-r)/(1+r)) in terms of H(..,r) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + dimension H1(n1:n2),H2(n1:n2,n1:n2),H3(n1:n2,n1:n2,n1:n2), + $ H4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) +** additional arrays required within this routine + dimension HR1(-1:1),HR2(-1:1,-1:1),HR3(-1:1,-1:1,-1:1), + $ HR4(-1:1,-1:1,-1:1,-1:1) +** the nw = 1 case + call fillh1(y,H1,HY1,Hi1,n1,n2) + if ( nw.eq.1 ) return +** the nw > 1 case + r = (1.d0-y)/(1.d0+y) +* print*,' eval1dhplat1: y = ',y,', r = ',r +** the whole (-1,1) range is in general needed for any pair (n1,n2) + call fillirr1dhplat0(r,nw,HR1,HR2,HR3,HR4,-1,1) +** fillirr1dhplat1 takes care automatically of all the immaginary +** parts as well as of the jump across y=1 + call fillirr1dhplat1(r,nw,HR1,HR2,HR3,HR4, + $ HY1,HY2,HY3,HY4, + $ Hi1,Hi2,Hi3,Hi4,n1,n2) +** then the reducible 1dHPL's + call fillred1dhpl(nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + end +************************************************************************ + subroutine eval1dhplatinf(y,nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates 1dhpl's in the inf-range (r2+1) < abs(y) +** evaluating first the H(..,x=1/y) by calling eval1dhplat0(x) +** and then expressing H(..,y=1/x) in terms of H(..,x) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + dimension H1(n1:n2),H2(n1:n2,n1:n2),H3(n1:n2,n1:n2,n1:n2), + $ H4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) +** additional arrays required within this routine + dimension HX1(n1:n2),HX2(n1:n2,n1:n2),HX3(n1:n2,n1:n2,n1:n2), + $ HX4(n1:n2,n1:n2,n1:n2,n1:n2) + parameter (pi = 3.14159265358979324d0) +** the nw = 1 case + call fillh1(y,H1,HY1,Hi1,n1,n2) + if ( nw.eq.1 ) return +** the nw > 1 case + x = 1.d0/y +* print*,' eval1dhplatinf: y = ',y,', x = ',x + call fillirr1dhplat0(x,nw,HX1,HX2,HX3,HX4,n1,n2) +** fillirr1dhplatinf takes care automatically of all the immaginary +** parts as well as of the jump across y=1 + call fillirr1dhplatinf(x,nw,HX1,HX2,HX3,HX4, + $ HY1,HY2,HY3,HY4, + $ Hi1,Hi2,Hi3,Hi4,n1,n2) +** then the reducible 1dHPL's + call fillred1dhpl(nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) + return + end +************************************************************************ + subroutine eval1dhplinm1(y,nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates 1dhpl's for y=-1 (explicit values are tabulated) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + complex*16 G1,G2,G3,G4 + dimension H1(n1:n2),H2(n1:n2,n1:n2),H3(n1:n2,n1:n2,n1:n2), + $ H4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) +** additional arrays required within this routine + dimension G1(-n2:-n1),G2(-n2:-n1,-n2:-n1), + $ G3(-n2:-n1,-n2:-n1,-n2:-n1), + $ G4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) + dimension GY1(-n2:-n1),GY2(-n2:-n1,-n2:-n1), + $ GY3(-n2:-n1,-n2:-n1,-n2:-n1), + $ GY4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) + dimension Gi1(-n2:-n1),Gi2(-n2:-n1,-n2:-n1), + $ Gi3(-n2:-n1,-n2:-n1,-n2:-n1), + $ Gi4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) + common /fillred/infilldim,infill(3) + dimension istorfill(3) + dimension nphase(-1:1) + data nphase/-1,1,-1/ + parameter (pi = 3.14159265358979324d0) +* print*,' eval1dhplatm1: y = ',y + if (infilldim.eq.2) then + do i=1,2 + istorfill(i) = infill(i) + infill(i) = -istorfill(i) + enddo + endif +** evaluate H(...,-y) + call setzero(nw,Gi1,Gi2,Gi3,Gi4,-n2,-n1) + Gi1(0) = -1 + call eval1dhplin1(-y,nw,G1,G2,G3,G4, + $ GY1,GY2,GY3,GY4,Gi1,Gi2,Gi3,Gi4,-n2,-n1) + if (infilldim.eq.2) then + do i=1,2 + infill(i) = istorfill(i) + enddo + endif +** fill the arrays H's + do k1=n1,n2 + nph1 = nphase(k1) + HY1(k1) = nph1*GY1(-k1) + Hi1(k1) = - nph1*Gi1(-k1) + H1(k1) = dcmplx(HY1(k1),Hi1(k1)*pi) + if ( nw.gt.1 ) then + do k2=n1,n2 + nph2 = nph1*nphase(k2) + HY2(k1,k2) = nph2*GY2(-k1,-k2) + Hi2(k1,k2) = - nph2*Gi2(-k1,-k2) + H2(k1,k2) = dcmplx(HY2(k1,k2),Hi2(k1,k2)*pi) + if ( nw.gt.2 ) then + do k3=n1,n2 + nph3 = nph2*nphase(k3) + HY3(k1,k2,k3) = nph3*GY3(-k1,-k2,-k3) + Hi3(k1,k2,k3) = - nph3*Gi3(-k1,-k2,-k3) + H3(k1,k2,k3) = dcmplx(HY3(k1,k2,k3),Hi3(k1,k2,k3)*pi) + if ( nw.gt.3 ) then + do k4=n1,n2 + nph4 = nph3*nphase(k4) + HY4(k1,k2,k3,k4) = nph4*GY4(-k1,-k2,-k3,-k4) + Hi4(k1,k2,k3,k4) = - nph4*Gi4(-k1,-k2,-k3,-k4) + H4(k1,k2,k3,k4) = + $ dcmplx(HY4(k1,k2,k3,k4),Hi4(k1,k2,k3,k4)*pi) + enddo + endif + enddo + endif + enddo + endif + enddo + if (n1.eq.0) return +** correct the ill-defined entries + HY2(-1,0) = - HY2(0,-1) + Hi2(-1,0) = Hi1(0)*HY1(-1) + H2(-1,0) = dcmplx(HY2(-1,0),Hi2(-1,0)*pi) + if ( nw.eq.2 ) return + HY3(-1,0,0) = HY1(-1)*HY2(0,0)+HY3(0,0,-1) + Hi3(-1,0,0) = HY1(-1)*Hi2(0,0)-HY2(0,-1)*Hi1(0) + H3(-1,0,0) = dcmplx(HY3(-1,0,0),Hi3(-1,0,0)*pi) + if ( nw.eq.3 ) return + HY4(-1,0,0,0) = -HY2(0,-1)*HY2(0,0)-HY4(0,0,0,-1) + Hi4(-1,0,0,0) = HY1(-1)*Hi3(0,0,0)+HY3(0,0,-1)*Hi1(0) + H4(-1,0,0,0) = dcmplx(HY4(-1,0,0,0),Hi4(-1,0,0,0)*pi) + return + end +************************************************************************ + subroutine eval1dhplatm1(y,nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates 1dhpl's in the (-1)-range -(r2+1) < y <= -(r2-1) +** evaluating first the H(..,-y) by calling eval1dhplat1(-y), +** and then expressing H(..,y) in terms of H(..,-y) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + complex*16 G1,G2,G3,G4 + dimension H1(n1:n2),H2(n1:n2,n1:n2),H3(n1:n2,n1:n2,n1:n2), + $ H4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) +** additional arrays required within this routine + dimension G1(-n2:-n1),G2(-n2:-n1,-n2:-n1), + $ G3(-n2:-n1,-n2:-n1,-n2:-n1), + $ G4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) + dimension GY1(-n2:-n1),GY2(-n2:-n1,-n2:-n1), + $ GY3(-n2:-n1,-n2:-n1,-n2:-n1), + $ GY4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) + dimension Gi1(-n2:-n1),Gi2(-n2:-n1,-n2:-n1), + $ Gi3(-n2:-n1,-n2:-n1,-n2:-n1), + $ Gi4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) +** + common /fillred/infilldim,infill(3) + dimension istorfill(3) + dimension nphase(-1:1) + data nphase/-1,1,-1/ + parameter (pi = 3.14159265358979324d0) +* print*,' eval1dhplatm1: y = ',y + if (infilldim.eq.2) then + do i=1,2 + istorfill(i) = infill(i) + infill(i) = -istorfill(i) + enddo + endif +** evaluate H(...,-y) + call setzero(nw,Gi1,Gi2,Gi3,Gi4,-n2,-n1) + Gi1(0) = -1 + call eval1dhplat1(-y,nw,G1,G2,G3,G4, + $ GY1,GY2,GY3,GY4,Gi1,Gi2,Gi3,Gi4,-n2,-n1) + if (infilldim.eq.2) then + do i=1,2 + infill(i) = istorfill(i) + enddo + endif +** fill the arrays H's + do k1=n1,n2 + nph1 = nphase(k1) + HY1(k1) = nph1*GY1(-k1) + Hi1(k1) = - nph1*Gi1(-k1) + H1(k1) = dcmplx(HY1(k1),Hi1(k1)*pi) + if ( nw.gt.1 ) then + do k2=n1,n2 + nph2 = nph1*nphase(k2) + HY2(k1,k2) = nph2*GY2(-k1,-k2) + Hi2(k1,k2) = - nph2*Gi2(-k1,-k2) + H2(k1,k2) = dcmplx(HY2(k1,k2),Hi2(k1,k2)*pi) + if ( nw.gt.2 ) then + do k3=n1,n2 + nph3 = nph2*nphase(k3) + HY3(k1,k2,k3) = nph3*GY3(-k1,-k2,-k3) + Hi3(k1,k2,k3) = - nph3*Gi3(-k1,-k2,-k3) + H3(k1,k2,k3) = dcmplx(HY3(k1,k2,k3),Hi3(k1,k2,k3)*pi) + if ( nw.gt.3 ) then + do k4=n1,n2 + nph4 = nph3*nphase(k4) + HY4(k1,k2,k3,k4) = nph4*GY4(-k1,-k2,-k3,-k4) + Hi4(k1,k2,k3,k4) = - nph4*Gi4(-k1,-k2,-k3,-k4) + H4(k1,k2,k3,k4) = + $ dcmplx(HY4(k1,k2,k3,k4),Hi4(k1,k2,k3,k4)*pi) + enddo + endif + enddo + endif + enddo + endif + enddo + return + end + + + subroutine eval1dhplatminf(y,nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates 1dhpl's in the (-1)-range y <= -(r2+1) +** evaluating first the H(..,-y) by calling eval1dhplatinf(-y), +** and then expressing H(..,y) in terms of H(..,-y) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + complex*16 G1,G2,G3,G4 + dimension H1(n1:n2),H2(n1:n2,n1:n2),H3(n1:n2,n1:n2,n1:n2), + $ H4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) +** additional arrays required within this routine + dimension G1(-n2:-n1),G2(-n2:-n1,-n2:-n1), + $ G3(-n2:-n1,-n2:-n1,-n2:-n1), + $ G4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) + dimension GY1(-n2:-n1),GY2(-n2:-n1,-n2:-n1), + $ GY3(-n2:-n1,-n2:-n1,-n2:-n1), + $ GY4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) + dimension Gi1(-n2:-n1),Gi2(-n2:-n1,-n2:-n1), + $ Gi3(-n2:-n1,-n2:-n1,-n2:-n1), + $ Gi4(-n2:-n1,-n2:-n1,-n2:-n1,-n2:-n1) +** + common /fillred/infilldim,infill(3) + dimension istorfill(3) + dimension nphase(-1:1) + data nphase/-1,1,-1/ + parameter (pi = 3.14159265358979324d0) +* print*,' eval1dhplatm1: y = ',y + if (infilldim.eq.2) then + do i=1,2 + istorfill(i) = infill(i) + infill(i) = -istorfill(i) + enddo + endif +** evaluate H(...,-y) + call setzero(nw,Gi1,Gi2,Gi3,Gi4,-n2,-n1) + Gi1(0) = -1 + call eval1dhplatinf(-y,nw,G1,G2,G3,G4, + $ GY1,GY2,GY3,GY4,Gi1,Gi2,Gi3,Gi4,-n2,-n1) + if (infilldim.eq.2) then + do i=1,2 + infill(i) = istorfill(i) + enddo + endif +** fill the arrays H's + do k1=n1,n2 + nph1 = nphase(k1) + HY1(k1) = nph1*GY1(-k1) + Hi1(k1) = - nph1*Gi1(-k1) + H1(k1) = dcmplx(HY1(k1),Hi1(k1)*pi) + if ( nw.gt.1 ) then + do k2=n1,n2 + nph2 = nph1*nphase(k2) + HY2(k1,k2) = nph2*GY2(-k1,-k2) + Hi2(k1,k2) = - nph2*Gi2(-k1,-k2) + H2(k1,k2) = dcmplx(HY2(k1,k2),Hi2(k1,k2)*pi) + if ( nw.gt.2 ) then + do k3=n1,n2 + nph3 = nph2*nphase(k3) + HY3(k1,k2,k3) = nph3*GY3(-k1,-k2,-k3) + Hi3(k1,k2,k3) = - nph3*Gi3(-k1,-k2,-k3) + H3(k1,k2,k3) = dcmplx(HY3(k1,k2,k3),Hi3(k1,k2,k3)*pi) + if ( nw.gt.3 ) then + do k4=n1,n2 + nph4 = nph3*nphase(k4) + HY4(k1,k2,k3,k4) = nph4*GY4(-k1,-k2,-k3,-k4) + Hi4(k1,k2,k3,k4) = - nph4*Gi4(-k1,-k2,-k3,-k4) + H4(k1,k2,k3,k4) = + $ dcmplx(HY4(k1,k2,k3,k4),Hi4(k1,k2,k3,k4)*pi) + enddo + endif + enddo + endif + enddo + endif + enddo + return + end +************************************************************************ + subroutine setzero(nw,Hi1,Hi2,Hi3,Hi4,n1,n2) +** initializes with 0 the elements of the arrays + implicit double precision (a-h,o-z) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) + do k1=n1,n2 + Hi1(k1) = 0.d0 + if ( nw.gt.1 ) then + do k2=n1,n2 + Hi2(k1,k2) = 0.d0 + if ( nw.gt.2 ) then + do k3=n1,n2 + Hi3(k1,k2,k3) = 0.d0 + if ( nw.gt.3 ) then + do k4=n1,n2 + Hi4(k1,k2,k3,k4) = 0.d0 + enddo + endif + enddo + endif + enddo + endif + enddo + return + end +************************************************************************ + subroutine fillred1dhpl(nw,H1,H2,H3,H4, + $ HY1,HY2,HY3,HY4,Hi1,Hi2,Hi3,Hi4,n1,n2) +* fills the reducible 1dhpl from the irreducible set + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + dimension H1(n1:n2),H2(n1:n2,n1:n2),H3(n1:n2,n1:n2,n1:n2), + $ H4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) + common /fillred/infilldim,infill(3) + parameter (pinv = 0.318309886183790672d0) + parameter (pi = 3.14159265358979324d0) +** combining real and immaginary into the complex value + do k1=n1,n2 + do k2=n1,n2 + H2(k1,k2) = dcmplx(HY2(k1,k2),Hi2(k1,k2)*pi) + if ( nw.gt.2 ) then + do k3=n1,n2 + H3(k1,k2,k3) = dcmplx(HY3(k1,k2,k3),Hi3(k1,k2,k3)*pi) + if ( nw.gt.3 ) then + do k4=n1,n2 + H4(k1,k2,k3,k4) = + $ dcmplx(HY4(k1,k2,k3,k4),Hi4(k1,k2,k3,k4)*pi) + enddo + endif + enddo + endif + enddo + enddo +** evaluating the reduced HPL's +** iflag = 0 to suppress auxiliary printings of FILLREDHPLx + iflag = 0 + do ia = 1,infilldim + do ib = ia,infilldim + call FILLREDHPL2(iflag,H1,H2,n1,n2,infill(ia),infill(ib)) + if ( nw.gt.2 ) then + do ic = ib,infilldim + call FILLREDHPL3(iflag,H1,H2,H3,n1,n2, + $ infill(ia),infill(ib),infill(ic)) + if ( nw.gt.3 ) then + do id = ic,infilldim + call FILLREDHPL4(iflag,H1,H2,H3,H4,n1,n2, + $ infill(ia),infill(ib),infill(ic),infill(id)) + enddo + endif + enddo + endif + enddo + enddo +** extractin real and immaginary parts from the complex value + do k1=n1,n2 + do k2=n1,n2 + HY2(k1,k2) = dble(H2(k1,k2)) + Hi2(k1,k2) = aimag(H2(k1,k2))*pinv + if ( nw.gt.2 ) then + do k3=n1,n2 + HY3(k1,k2,k3) = dble(H3(k1,k2,k3)) + Hi3(k1,k2,k3) = aimag(H3(k1,k2,k3))*pinv + if ( nw.gt.3 ) then + do k4=n1,n2 + HY4(k1,k2,k3,k4) = dble(H4(k1,k2,k3,k4)) + Hi4(k1,k2,k3,k4) = aimag(H4(k1,k2,k3,k4))*pinv + enddo + endif + enddo + endif + enddo + enddo + return + end +************************************************************************ + subroutine FILLREDHPL2(iflag,H1,H2,i1,i2,na,nb) + implicit double precision (a-h,o-z) + complex*16 H1,H2 + dimension H1(i1:i2),H2(i1:i2,i1:i2) +*23456789012345678901234567890123456789012345678901234567890123456789012 +* must be called with ordered indices na <= nb +* print*,' FILLREDHPL2, iflag =',iflag + if ( na.eq.nb ) then + H2(na,na) = 1.d0/2*( H1(na) )**2 + else + H2(nb,na) = + H1(na)*H1(nb) - H2(na,nb) + if ( iflag.eq.1 ) then + call printer2(na,nb) + endif + endif + return + end +************************************************************************ + subroutine FILLREDHPL3(iflag,H1,H2,H3,i1,i2,ia,ib,ic) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3 + dimension H1(i1:i2),H2(i1:i2,i1:i2),H3(i1:i2,i1:i2,i1:i2) +* must be called with "properly ordered" indices +* note in particular the remapping of, say, (ia,ib,ic) into +* (na,na,nb) of ReducerTest.out + na = ia + if ( (ia.eq.ib).and.(ib.eq.ic) ) then +* case (na,na,na) + H3(na,na,na) = 1.d0/6*( H1(na) )**3 +* ic cannot be anymore equal to ia + else if ( ic.eq.ia ) then + print*,' FILLREDHPL3, error 1, called with arguments ' + print*,' ',ia,ib,ic + stop + else if ( ia.eq.ib ) then +* case (na,na,nb) + nb = ic + if ( iflag.eq.1 ) then + call printer3(na,na,nb) + endif + H3(na,nb,na) = + H1(na)*H2(na,nb) - 2*H3(na,na,nb) + H3(nb,na,na) = + 1.d0/2*H1(na)*H1(na)*H1(nb) + $ - H1(na)*H2(na,nb) + H3(na,na,nb) +* ib cannot be anymore equal to ia + else if ( ib.eq.ia ) then + print*,' FILLREDHPL3, error 2, called with arguments ' + print*,' ',ia,ib,ic + stop + else if ( ib.eq.ic ) then +* case (na,nb,nb) + nb = ib + if ( iflag.eq.1 ) then + call printer3(na,nb,nb) + endif + H3(nb,na,nb) = + H1(nb)*H2(na,nb) - 2*H3(na,nb,nb) + H3(nb,nb,na) = + 1.d0/2*H1(na)*H1(nb)*H1(nb) + $ - H1(nb)*H2(na,nb) + H3(na,nb,nb) +* no need to protect against ic.eq.ib +* when arriving here all indices are different + else +* case (na,nb,nc) all indices are different + nb = ib + nc = ic + if ( iflag.eq.1 ) then + call printer3(na,nb,nc) + call printer3(na,nc,nb) + endif + H3(nb,na,nc) = + H1(nb)*H2(na,nc) + $ - H3(na,nb,nc) - H3(na,nc,nb) + H3(nb,nc,na) = + H1(na)*H2(nb,nc) + $ - H1(nb)*H2(na,nc) + H3(na,nc,nb) + H3(nc,na,nb) = + H1(nc)*H2(na,nb) + $ - H3(na,nb,nc) - H3(na,nc,nb) + H3(nc,nb,na) = + H1(na)*H1(nb)*H1(nc) - H1(na)*H2(nb,nc) + $ - H1(nc)*H2(na,nb) + H3(na,nb,nc) + endif +*23456789012345678901234567890123456789012345678901234567890123456789012 + return + end +************************************************************************ + subroutine FILLREDHPL4(iflag,H1,H2,H3,H4,i1,i2,ia,ib,ic,id) + implicit double precision (a-h,o-z) + complex*16 H1,H2,H3,H4 + dimension H1(i1:i2),H2(i1:i2,i1:i2),H3(i1:i2,i1:i2,i1:i2) + dimension H4(i1:i2,i1:i2,i1:i2,i1:i2) +*23456789012345678901234567890123456789012345678901234567890123456789012 +* must be called with "properly ordered" indices +* note in particular the remapping of, say, (ia,ib,ic) into +* (na,na,nb) of ReducerTest.out + na = ia + if ( (ia.eq.ib).and.(ib.eq.ic).and.(ic.eq.id) ) then +* case (na,na,na,na) + H4(na,na,na,na) = 1.d0/24*( H1(na) )**4 +* id cannot be anymore equal to ia + else if ( id.eq.ia ) then + print*,' FILLREDHPL4, error 1, called with arguments ' + print*,' ',ia,ib,ic,id + stop + else if ( (ia.eq.ib).and.(ib.eq.ic) ) then +* case (na,na,na,nb) + nb = id + H4(na,na,nb,na) = + H1(na)*H3(na,na,nb) - 3*H4(na,na,na,nb) + H4(na,nb,na,na) = + 1.d0/2*H1(na)*H1(na)*H2(na,nb) + $ - 2*H1(na)*H3(na,na,nb) + 3*H4(na,na,na,nb) + H4(nb,na,na,na) = + 1.d0/6*H1(na)*H1(na)*H1(na)*H1(nb) + $ - 1.d0/2*H1(na)*H1(na)*H2(na,nb) + $ + H1(na)*H3(na,na,nb) - H4(na,na,na,nb) + if ( iflag.eq.1 ) then + call printer4(na,na,na,nb) + endif +* ic cannot be anymore equal to ia + else if ( ic.eq.ia ) then + print*,' FILLREDHPL4, error 2, called with arguments ' + print*,' ',ia,ib,ic,id + stop + else if ( (ia.eq.ib).and.(ic.eq.id) ) then +* case (na,na,nb,nb) + nb = ic + H4(na,nb,na,nb) = + 1.d0/2*H2(na,nb)*H2(na,nb) + $ - 2*H4(na,na,nb,nb) + H4(na,nb,nb,na) = + H1(na)*H3(na,nb,nb) + $ - 1.d0/2*H2(na,nb)*H2(na,nb) + H4(nb,na,na,nb) = + H1(nb)*H3(na,na,nb) + $ - 1.d0/2*H2(na,nb)*H2(na,nb) + H4(nb,na,nb,na) = + H1(na)*H1(nb)*H2(na,nb) + $ - 2*H1(na)*H3(na,nb,nb) + $ - 2*H1(nb)*H3(na,na,nb) + $ + 1.d0/2*H2(na,nb)*H2(na,nb) + $ + 2*H4(na,na,nb,nb) + H4(nb,nb,na,na) = + 1.d0/4*H1(na)*H1(na)*H1(nb)*H1(nb) + $ - H1(na)*H1(nb)*H2(na,nb) + $ + H1(na)*H3(na,nb,nb) + $ + H1(nb)*H3(na,na,nb) - H4(na,na,nb,nb) + if ( iflag.eq.1 ) then + call printer4(na,na,nb,nb) + endif + else if ( ia.eq.ib ) then +* case (na,na,nb,nc) + nb = ic + nc = id + H4(na,nb,nc,na) = + H1(na)*H3(na,nb,nc) - 2*H4(na,na,nb,nc) + $ - H4(na,nb,na,nc) + H4(na,nc,na,nb) = + H2(na,nb)*H2(na,nc) - 2*H4(na,na,nb,nc) + $ - 2*H4(na,na,nc,nb) - H4(na,nb,na,nc) + H4(na,nc,nb,na) = + H1(na)*H3(na,nc,nb) - H2(na,nb)*H2(na,nc) + $ + 2*H4(na,na,nb,nc) + H4(na,nb,na,nc) + H4(nb,na,na,nc) = + H1(nb)*H3(na,na,nc) - H4(na,na,nb,nc) + $ - H4(na,na,nc,nb) - H4(na,nb,na,nc) + H4(nb,na,nc,na) = + H1(na)*H1(nb)*H2(na,nc) + $ - H1(na)*H3(na,nb,nc) - H1(na)*H3(na,nc,nb) + $ - 2*H1(nb)*H3(na,na,nc) + 2*H4(na,na,nb,nc) + $ + 2*H4(na,na,nc,nb) + H4(na,nb,na,nc) + H4(nb,nc,na,na) = + 1.d0/2*H1(na)*H1(na)*H2(nb,nc) + $ - H1(na)*H1(nb)*H2(na,nc) + $ + H1(na)*H3(na,nc,nb) + H1(nb)*H3(na,na,nc) + $ - H4(na,na,nc,nb) + H4(nc,na,na,nb) = + H1(nc)*H3(na,na,nb) - H2(na,nb)*H2(na,nc) + $ + H4(na,na,nb,nc) + H4(na,na,nc,nb) + $ + H4(na,nb,na,nc) + H4(nc,na,nb,na) = + H1(na)*H1(nc)*H2(na,nb) + $ - H1(na)*H3(na,nb,nc) - H1(na)*H3(na,nc,nb) + $ - 2*H1(nc)*H3(na,na,nb) + H2(na,nb)*H2(na,nc) + $ - H4(na,nb,na,nc) + H4(nc,nb,na,na) = + 1.d0/2*H1(na)*H1(na)*H1(nb)*H1(nc) + $ - 1.d0/2*H1(na)*H1(na)*H2(nb,nc) + $ - H1(na)*H1(nc)*H2(na,nb) + $ + H1(na)*H3(na,nb,nc) + H1(nc)*H3(na,na,nb) + $ - H4(na,na,nb,nc) + if ( iflag.eq.1 ) then + call printer4(na,na,nb,nc) + call printer4(na,na,nc,nb) + call printer4(na,nb,na,nc) + endif +* ib cannot be anymore equal to ia + else if ( ib.eq.ia ) then + print*,' FILLREDHPL4, error 3, called with arguments ' + print*,' ',ia,ib,ic,id + stop + else if ( (ib.eq.ic).and.(ic.eq.id) ) then +* case (na,nb,nb,nb) + nb = ib + H4(nb,na,nb,nb) = + H1(nb)*H3(na,nb,nb) - 3*H4(na,nb,nb,nb) + H4(nb,nb,na,nb) = + 1.d0/2*H1(nb)*H1(nb)*H2(na,nb) + $ - 2*H1(nb)*H3(na,nb,nb) + 3*H4(na,nb,nb,nb) + H4(nb,nb,nb,na) = + 1.d0/6*H1(na)*H1(nb)*H1(nb)*H1(nb) + $ - 1.d0/2*H1(nb)*H1(nb)*H2(na,nb) + $ + H1(nb)*H3(na,nb,nb) - H4(na,nb,nb,nb) + if ( iflag.eq.1 ) then + call printer4(na,nb,nb,nb) + endif +* id cannot be anymore equal to ib + else if ( id.eq.ib ) then + print*,' FILLREDHPL4, error 4, called with arguments ' + print*,' ',ia,ib,ic,id + stop + else if ( ib.eq.ic ) then +* case (na,nb,nb,nc) + nb = ib + nc = id + H4(nb,na,nb,nc) = + H1(nb)*H3(na,nb,nc) + $ - 2*H4(na,nb,nb,nc) - H4(na,nb,nc,nb) + H4(nb,na,nc,nb) = + H1(nb)*H3(na,nc,nb) - H4(na,nb,nc,nb) + $ - 2*H4(na,nc,nb,nb) + H4(nb,nb,na,nc) = + 1.d0/2*H1(nb)*H1(nb)*H2(na,nc) + $ - H1(nb)*H3(na,nb,nc) - H1(nb)*H3(na,nc,nb) + $ + H4(na,nb,nb,nc) + H4(na,nb,nc,nb) + $ + H4(na,nc,nb,nb) + H4(nb,nb,nc,na) = + H1(na)*H3(nb,nb,nc) + $ - 1.d0/2*H1(nb)*H1(nb)*H2(na,nc) + $ + H1(nb)*H3(na,nc,nb) - H4(na,nc,nb,nb) + H4(nb,nc,na,nb) = - H1(nb)*H3(na,nb,nc) - H1(nb)*H3(na,nc,nb) + $ + H2(na,nb)*H2(nb,nc) + H4(na,nb,nc,nb) + $ + 2*H4(na,nc,nb,nb) + H4(nb,nc,nb,na) = + H1(na)*H1(nb)*H2(nb,nc) + $ - 2*H1(na)*H3(nb,nb,nc) + $ + H1(nb)*H3(na,nb,nc) + $ - H2(na,nb)*H2(nb,nc) - H4(na,nb,nc,nb) + H4(nc,na,nb,nb) = + H1(nc)*H3(na,nb,nb) - H4(na,nb,nb,nc) + $ - H4(na,nb,nc,nb) - H4(na,nc,nb,nb) + H4(nc,nb,na,nb) = + H1(nb)*H1(nc)*H2(na,nb) + $ - 2*H1(nc)*H3(na,nb,nb) + $ - H2(na,nb)*H2(nb,nc) + 2*H4(na,nb,nb,nc) + $ + H4(na,nb,nc,nb) + H4(nc,nb,nb,na) = + 1.d0/2*H1(na)*H1(nb)*H1(nb)*H1(nc) + $ - H1(na)*H1(nb)*H2(nb,nc) + $ + H1(na)*H3(nb,nb,nc) + $ - H1(nb)*H1(nc)*H2(na,nb) + $ + H1(nc)*H3(na,nb,nb) + H2(na,nb)*H2(nb,nc) + $ - H4(na,nb,nb,nc) + if ( iflag.eq.1 ) then + call printer4(na,nb,nb,nc) + call printer4(na,nb,nc,nb) + call printer4(na,nc,nb,nb) + endif +* ic cannot be anymore equal to ib + else if ( ic.eq.ib ) then + print*,' FILLREDHPL4, error 5, called with arguments ' + print*,' ',ia,ib,ic,id + stop + else if ( ic.eq.id ) then +* case (na,nb,nc,nc) + nb = ib + nc = ic + H4(nb,na,nc,nc) = + H1(nb)*H3(na,nc,nc) - H4(na,nb,nc,nc) + $ - H4(na,nc,nb,nc) - H4(na,nc,nc,nb) + H4(nb,nc,na,nc) = - 2*H1(nb)*H3(na,nc,nc) + H2(na,nc)*H2(nb,nc) + $ + H4(na,nc,nb,nc) + 2*H4(na,nc,nc,nb) + H4(nb,nc,nc,na) = + H1(na)*H3(nb,nc,nc) + H1(nb)*H3(na,nc,nc) + $ - H2(na,nc)*H2(nb,nc) - H4(na,nc,nc,nb) + H4(nc,na,nb,nc) = + H1(nc)*H3(na,nb,nc) - 2*H4(na,nb,nc,nc) + $ - H4(na,nc,nb,nc) + H4(nc,na,nc,nb) = + H1(nc)*H3(na,nc,nb) - H4(na,nc,nb,nc) + $ - 2*H4(na,nc,nc,nb) + H4(nc,nb,na,nc) = + H1(nb)*H1(nc)*H2(na,nc) + $ - H1(nc)*H3(na,nb,nc) - H1(nc)*H3(na,nc,nb) + $ - H2(na,nc)*H2(nb,nc) + 2*H4(na,nb,nc,nc) + $ + H4(na,nc,nb,nc) + H4(nc,nb,nc,na) = + H1(na)*H1(nc)*H2(nb,nc) + $ - 2*H1(na)*H3(nb,nc,nc) + $ - H1(nb)*H1(nc)*H2(na,nc) + $ + H1(nc)*H3(na,nc,nb) + H2(na,nc)*H2(nb,nc) + $ - H4(na,nc,nb,nc) + H4(nc,nc,na,nb) = + 1.d0/2*H1(nc)*H1(nc)*H2(na,nb) + $ - H1(nc)*H3(na,nb,nc) - H1(nc)*H3(na,nc,nb) + $ + H4(na,nb,nc,nc) + H4(na,nc,nb,nc) + $ + H4(na,nc,nc,nb) + H4(nc,nc,nb,na) = + 1.d0/2*H1(na)*H1(nb)*H1(nc)*H1(nc) + $ - H1(na)*H1(nc)*H2(nb,nc) + $ + H1(na)*H3(nb,nc,nc) + $ - 1.d0/2*H1(nc)*H1(nc)*H2(na,nb) + $ + H1(nc)*H3(na,nb,nc) - H4(na,nb,nc,nc) + if ( iflag.eq.1 ) then + call printer4(na,nb,nc,nc) + call printer4(na,nc,nb,nc) + call printer4(na,nc,nc,nb) + endif +* no need to protect against id.eq.ic +* when arriving here all indices are different + else +* case (na,nb,nc,nd) all indices are different + nb = ib + nc = ic + nd = id + H4(nb,na,nc,nd) = + H1(nb)*H3(na,nc,nd) - H4(na,nb,nc,nd) + $ - H4(na,nc,nb,nd) - H4(na,nc,nd,nb) + H4(nb,na,nd,nc) = + H1(nb)*H3(na,nd,nc) - H4(na,nb,nd,nc) + $ - H4(na,nd,nb,nc) - H4(na,nd,nc,nb) + H4(nb,nc,na,nd) = - H1(nb)*H3(na,nc,nd) - H1(nb)*H3(na,nd,nc) + $ + H2(na,nd)*H2(nb,nc) + H4(na,nc,nb,nd) + $ + H4(na,nc,nd,nb) + H4(na,nd,nc,nb) + H4(nb,nc,nd,na) = + H1(na)*H3(nb,nc,nd) + H1(nb)*H3(na,nd,nc) + $ - H2(na,nd)*H2(nb,nc) - H4(na,nd,nc,nb) + H4(nb,nd,na,nc) = - H1(nb)*H3(na,nc,nd) - H1(nb)*H3(na,nd,nc) + $ + H2(na,nc)*H2(nb,nd) + H4(na,nc,nd,nb) + $ + H4(na,nd,nb,nc) + H4(na,nd,nc,nb) + H4(nb,nd,nc,na) = + H1(na)*H3(nb,nd,nc) + H1(nb)*H3(na,nc,nd) + $ - H2(na,nc)*H2(nb,nd) - H4(na,nc,nd,nb) + H4(nc,na,nb,nd) = + H1(nc)*H3(na,nb,nd) - H4(na,nb,nc,nd) + $ - H4(na,nb,nd,nc) - H4(na,nc,nb,nd) + H4(nc,na,nd,nb) = + H1(nc)*H3(na,nd,nb) - H4(na,nc,nd,nb) + $ - H4(na,nd,nb,nc) - H4(na,nd,nc,nb) + H4(nc,nb,na,nd) = + H1(nb)*H1(nc)*H2(na,nd) + $ - H1(nc)*H3(na,nb,nd) - H1(nc)*H3(na,nd,nb) + $ - H2(na,nd)*H2(nb,nc) + H4(na,nb,nc,nd) + $ + H4(na,nb,nd,nc) + H4(na,nd,nb,nc) + H4(nc,nb,nd,na) = + H1(na)*H1(nc)*H2(nb,nd) + $ - H1(na)*H3(nb,nc,nd) - H1(na)*H3(nb,nd,nc) + $ - H1(nb)*H1(nc)*H2(na,nd) + $ + H1(nc)*H3(na,nd,nb) + H2(na,nd)*H2(nb,nc) + $ - H4(na,nd,nb,nc) + H4(nc,nd,na,nb) = - H1(nc)*H3(na,nb,nd) - H1(nc)*H3(na,nd,nb) + $ + H2(na,nb)*H2(nc,nd) + H4(na,nb,nd,nc) + $ + H4(na,nd,nb,nc) + H4(na,nd,nc,nb) + H4(nc,nd,nb,na) = + H1(na)*H1(nb)*H2(nc,nd) + $ - H1(na)*H1(nc)*H2(nb,nd) + $ + H1(na)*H3(nb,nd,nc) + H1(nc)*H3(na,nb,nd) + $ - H2(na,nb)*H2(nc,nd) - H4(na,nb,nd,nc) + H4(nd,na,nb,nc) = + H1(nd)*H3(na,nb,nc) - H4(na,nb,nc,nd) + $ - H4(na,nb,nd,nc) - H4(na,nd,nb,nc) + H4(nd,na,nc,nb) = + H1(nd)*H3(na,nc,nb) - H4(na,nc,nb,nd) + $ - H4(na,nc,nd,nb) - H4(na,nd,nc,nb) + H4(nd,nb,na,nc) = + H1(nb)*H1(nd)*H2(na,nc) + $ - H1(nd)*H3(na,nb,nc) - H1(nd)*H3(na,nc,nb) + $ - H2(na,nc)*H2(nb,nd) + H4(na,nb,nc,nd) + $ + H4(na,nb,nd,nc) + H4(na,nc,nb,nd) + H4(nd,nb,nc,na) = + H1(na)*H1(nd)*H2(nb,nc) + $ - H1(na)*H3(nb,nc,nd) - H1(na)*H3(nb,nd,nc) + $ - H1(nb)*H1(nd)*H2(na,nc) + $ + H1(nd)*H3(na,nc,nb) + H2(na,nc)*H2(nb,nd) + $ - H4(na,nc,nb,nd) + H4(nd,nc,na,nb) = + H1(nc)*H1(nd)*H2(na,nb) + $ - H1(nd)*H3(na,nb,nc) - H1(nd)*H3(na,nc,nb) + $ - H2(na,nb)*H2(nc,nd) + H4(na,nb,nc,nd) + $ + H4(na,nc,nb,nd) + H4(na,nc,nd,nb) + H4(nd,nc,nb,na) = + H1(na)*H1(nb)*H1(nc)*H1(nd) + $ - H1(na)*H1(nb)*H2(nc,nd) + $ - H1(na)*H1(nd)*H2(nb,nc) + $ + H1(na)*H3(nb,nc,nd) + $ - H1(nc)*H1(nd)*H2(na,nb) + $ + H1(nd)*H3(na,nb,nc) + $ + H2(na,nb)*H2(nc,nd) - H4(na,nb,nc,nd) + if ( iflag.eq.1 ) then + call printer4(na,nb,nc,nd) + call printer4(na,nb,nd,nc) + call printer4(na,nc,nb,nd) + call printer4(na,nc,nb,nd) + call printer4(na,nd,nb,nc) + call printer4(na,nd,nc,nb) + endif + endif +*23456789012345678901234567890123456789012345678901234567890123456789012 + return + end +************************************************************************ + subroutine printer2(na,nb) + + write(11,'(''g [H('',$)') + call subprint(11,na) + write(11,'('','',$)') + call subprint(11,nb) + write(11,'('',y)] = H('',$)') + call subprint(11,na) + write(11,'('','',$)') + call subprint(11,nb) + write(11,'('',y) ; '')') + + write(12,'(''id H('',$)') + call subprint(12,na) + write(12,'('','',$)') + call subprint(12,nb) + write(12,'('',y) = H[('',$)') + call subprint(12,na) + write(12,'('','',$)') + call subprint(12,nb) + write(12,'('',y)] ; '')') + + return + end +*** + subroutine printer3(na,nb,nc) + + write(11,'(''g [H('',$)') + call subprint(11,na) + write(11,'('','',$)') + call subprint(11,nb) + write(11,'('','',$)') + call subprint(11,nc) + write(11,'('',y)] = H('',$)') + call subprint(11,na) + write(11,'('','',$)') + call subprint(11,nb) + write(11,'('','',$)') + call subprint(11,nc) + write(11,'('',y) ; '')') + + write(12,'(''id H('',$)') + call subprint(12,na) + write(12,'('','',$)') + call subprint(12,nb) + write(12,'('','',$)') + call subprint(12,nc) + write(12,'('',y) = H[('',$)') + call subprint(12,na) + write(12,'('','',$)') + call subprint(12,nb) + write(12,'('',y)] ; '')') + + return + end +*** + subroutine printer4(na,nb,nc,nd) + + write(11,'(''g [H('',$)') + call subprint(11,na) + write(11,'('','',$)') + call subprint(11,nb) + write(11,'('','',$)') + call subprint(11,nc) + write(11,'('','',$)') + call subprint(11,nd) + write(11,'('',y)] = H('',$)') + call subprint(11,na) + write(11,'('','',$)') + call subprint(11,nb) + write(11,'('','',$)') + call subprint(11,nc) + write(11,'('','',$)') + call subprint(11,nd) + write(11,'('',y) ; '')') + + write(12,'(''id H('',$)') + call subprint(12,na) + write(12,'('','',$)') + call subprint(12,nb) + write(12,'('','',$)') + call subprint(12,nc) + write(12,'('','',$)') + call subprint(12,nd) + write(12,'('',y) = H[('',$)') + call subprint(12,na) + write(12,'('','',$)') + call subprint(12,nb) + write(12,'('','',$)') + call subprint(12,nc) + write(12,'('','',$)') + call subprint(12,nd) + write(12,'('',y)] ; '')') + + return + end +*** + subroutine subprint(n,na) + if ( na.lt.0 ) then + write (n,102) na + else + write (n,101) na + endif + return + 101 format(i1,$) + 102 format(i2,$) + end + +************************************************************************ +** the following routines contain th set of routines evaluating +** irreducible 1dhpl's for various values of the arguments +************************************************************************ + subroutine fillh1(y,H1,HY1,Hi1,n1,n2) +** fillh1 evaluates the 1dhpl's of weight 1 + implicit double precision (a-h,o-z) + complex*16 H1 + dimension H1(n1:n2) + dimension HY1(n1:n2) + dimension Hi1(n1:n2) + parameter (pi = 3.14159265358979324d0) + if ( n1.eq.-1) then + if ( y.ge.-1.d0 ) then + HY1(-1) = log(1.d0+y) + Hi1(-1) = 0.d0 + elseif ( y.lt.-1.d0 ) then + HY1(-1) = log(-1.d0-y) + Hi1(-1) = 1.d0 + endif + H1(-1) = dcmplx(HY1(-1),pi*Hi1(-1)) + endif + if ( y.ge.0.d0 ) then + HY1(0) = log(y) +* Hi1(0) = 0.d0 + elseif ( y.lt.0.d0 ) then + HY1(0) = log(-y) + Hi1(0) = 1.d0 + endif + H1(0) = dcmplx(HY1(0),pi*Hi1(0)) + if ( n2.eq.1 ) then + if ( y.ge.1.d0 ) then + HY1(1) = - log(-1.d0+y) + Hi1(1) = 1.d0 + elseif ( y.lt.1.d0 ) then + HY1(1) = - log(1.d0-y) + Hi1(1) = 0.d0 + endif + H1(1) = dcmplx(HY1(1),pi*Hi1(1)) + endif + return + end +************************************************************************ + subroutine fillirr1dhplat0(y,nw,HY1,HY2,HY3,HY4,n1,n2) +** evaluate the HPL from their power series expansions +** fillirr1dhplat0 is called by eval1dhplat0; +** it is guaranteed that nw is in the range 1:4, and that (n1,n2) +** take one of the pairs of values (0,1), (-1,0) or (-1,1) +** +** for y < 0 DOES NOT evaluates the immaginary part of H(0,y) = log(y) + implicit double precision (a-h,o-z) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) +** evaluating the required 1dHPL of weight 1 + if ( n1.eq.-1) then +** 1+y = (1+ep)/(1-ep), ep = y/(2+y) +** log(1+y) = log((1+y)/(1-y)) = 2*ep*(1+ep^2/3+ep^4/5+.....) +** at y= -(r2-1) = - 0.4142135624, ep = - 0.26120387496 +** ep2 = 0.068227464296, ep2^13 = 6.9 x 10^(-16) + ep = y/(2.d0+y) + e2 = ep*ep +* v = log(1.d0+y) + v = 2*ep*(1+e2*(1.d0/ 3+e2*(1.d0/ 5+e2*(1.d0/ 7+e2*(1.d0/ 9 + $ +e2*(1.d0/11+e2*(1.d0/13+e2*(1.d0/15+e2*(1.d0/17 + $ +e2*(1.d0/19+e2*(1.d0/21+e2*(1.d0/23+e2*(1.d0/25 + $ ))))))))))))) + HY1(-1) = v + endif + if (y.ge.0d0) then + HY1(0) = log(y) + else + HY1(0) = log(-y) +** the immaginary part is evaluated in the calling routine eval1dhplat0 +** Hi1(0) = 1d0 + endif + if ( n2.eq.1) then +** 1-y = (1-ep)/(1+ep), ep = y/(2-y) + ep = y/(2.d0-y) + e2 = ep*ep +* u = - log(1.d0-y) + u = 2*ep*(1+e2*(1.d0/ 3+e2*(1.d0/ 5+e2*(1.d0/ 7+e2*(1.d0/ 9 + $ +e2*(1.d0/11+e2*(1.d0/13+e2*(1.d0/15+e2*(1.d0/17 + $ +e2*(1.d0/19+e2*(1.d0/21+e2*(1.d0/23+e2*(1.d0/25 + $ ))))))))))))) + HY1(1) = u + endif + if ( nw.eq.1 ) return +** from now on nw > 1 +** evaluating the Cebyshev polynomials for the expansions + ep = y + if ( n2.eq.1) then + tu01 = 20d0/11d0*u + tu02 = 2d0*tu01*tu01 - 1d0 + tu03 = 2d0*tu01*tu02 - tu01 + tu04 = 2d0*tu01*tu03 - tu02 + tu05 = 2d0*tu01*tu04 - tu03 + tu06 = 2d0*tu01*tu05 - tu04 + tu07 = 2d0*tu01*tu06 - tu05 + tu08 = 2d0*tu01*tu07 - tu06 + tu09 = 2d0*tu01*tu08 - tu07 + tu10 = 2d0*tu01*tu09 - tu08 + tu11 = 2d0*tu01*tu10 - tu09 + tu12 = 2d0*tu01*tu11 - tu10 + endif + if ( n1.eq.-1 ) then + tv01 = 20d0/11d0*v + tv02 = 2d0*tv01*tv01 - 1d0 + tv03 = 2d0*tv01*tv02 - tv01 + tv04 = 2d0*tv01*tv03 - tv02 + tv05 = 2d0*tv01*tv04 - tv03 + tv06 = 2d0*tv01*tv05 - tv04 + tv07 = 2d0*tv01*tv06 - tv05 + tv08 = 2d0*tv01*tv07 - tv06 + tv09 = 2d0*tv01*tv08 - tv07 + tv10 = 2d0*tv01*tv09 - tv08 + tv11 = 2d0*tv01*tv10 - tv09 + tv12 = 2d0*tv01*tv11 - tv10 + endif +** evaluating the expansions +** (n1,n2) = (0,1) or (-1,1) + if ( ( (n1.eq.0).and.(n2.eq.1) ) + $ .or.( (n1.eq.-1).and.(n2.eq.1) ) ) then + HY2(0,1) = + $ - 3.781250000000000d-02 + $ + 5.534574473824441d-01*tu01 + $ - 3.781250000000000d-02*tu02 + $ + 1.151036617760703d-03*tu03 + $ - 8.659502433858922d-07*tu05 + $ + 1.109042494804544d-09*tu07 + $ - 1.624415058184216d-12*tu09 + $ + 2.528376460336939d-15*tu11 +** it would be wrong to write +** if ( nw.eq.2 ) return +** because the (n1.eq.-1).and.(n2.eq.1) case is not yet complete + if ( nw.gt.2 ) then + HY3(0,0,1) = + $ - 5.701592410758114d-02 + $ + 5.598247957892565d-01*tu01 + $ - 5.711486614505007d-02*tu02 + $ + 3.275603992203700d-03*tu03 + $ - 9.887255877938583d-05*tu04 + $ + 4.021153684652295d-07*tu05 + $ + 6.939288687864526d-08*tu06 + $ - 7.995347631322020d-10*tu07 + $ - 8.567978673919505d-11*tu08 + $ + 1.526387027481200d-12*tu09 + $ + 1.226899454816980d-13*tu10 + $ - 2.848614761014972d-15*tu11 + $ - 1.880542777479446d-16*tu12 + HY3(0,1,1) = + $ + 3.816894981500984d-02 + $ - 1.039843750000000d-02*tu01 + $ + 3.828760080995617d-02*tu02 + $ - 3.466145833333333d-03*tu03 + $ + 1.185518160084905d-04*tu04 + $ - 9.904555648775859d-08*tu06 + $ + 1.331803984518588d-10*tu08 + $ - 2.006389465106708d-13*tu10 + $ + 3.180731062055677d-16*tu12 + endif + if ( nw.gt.3 ) then + HY4(0,0,0,1) = + $ - 6.685228257646101d-02 + $ + 5.645990701998083d-01*tu01 + $ - 6.707912936340146d-02*tu02 + $ + 4.876429488624746d-03*tu03 + $ - 2.268732672568699d-04*tu04 + $ + 6.038494106229146d-06*tu05 + $ - 2.642577015932576d-08*tu06 + $ - 3.679843316593900d-09*tu07 + $ + 5.444046563879984d-11*tu08 + $ + 4.063821221202881d-12*tu09 + $ - 1.055985864474070d-13*tu10 + $ - 5.190408125225683d-15*tu11 + $ + 1.985464489219049d-16*tu12 + HY4(0,0,1,1) = + $ + 1.953236111099851d-02 + $ - 8.741612828671381d-03*tu01 + $ + 1.974116110893196d-02*tu02 + $ - 2.926558492394004d-03*tu03 + $ + 2.088576190269387d-04*tu04 + $ - 7.604351107741397d-06*tu05 + $ + 5.751031394942524d-08*tu06 + $ + 5.832253077603139d-09*tu07 + $ - 1.105713721511985d-10*tu08 + $ - 7.453416210082473d-12*tu09 + $ + 2.077758906032370d-13*tu10 + $ + 1.085601519719514d-14*tu11 + $ - 3.848312092795918d-16*tu12 + HY4(0,1,1,1) = + $ - 7.148925781250000d-04 + $ + 7.019393481825299d-03*tu01 + $ - 9.531901041666666d-04*tu02 + $ + 2.354287493676137d-03*tu03 + $ - 2.382975260416666d-04*tu04 + $ + 8.682904829408987d-06*tu05 + $ - 7.768198634676578d-09*tu07 + $ + 1.083130072188330d-11*tu09 + $ - 1.668810490326842d-14*tu11 + endif +** nw > 3 endif + endif +** (n1,n2) = (0,1) or (-1,1) endif +************ +** (n1,n2) = (-1,0) or (-1,1) + if ( ( (n1.eq.-1).and.(n2.eq.0) ) + $ .or.( (n1.eq.-1).and.(n2.eq.1) ) ) then + HY2(0,-1) = + $ + 3.781250000000000d-02 + $ + 5.534574473824441d-01*tv01 + $ + 3.781250000000000d-02*tv02 + $ + 1.151036617760703d-03*tv03 + $ - 8.659502433858922d-07*tv05 + $ + 1.109042494804544d-09*tv07 + $ - 1.624415058184216d-12*tv09 + $ + 2.528376460336939d-15*tv11 + if ( nw.gt.2 ) then + HY3(0,0,-1) = + $ + 5.701592410758114d-02 + $ + 5.598247957892565d-01*tv01 + $ + 5.711486614505007d-02*tv02 + $ + 3.275603992203700d-03*tv03 + $ + 9.887255877938583d-05*tv04 + $ + 4.021153684652295d-07*tv05 + $ - 6.939288687864526d-08*tv06 + $ - 7.995347631322020d-10*tv07 + $ + 8.567978673919505d-11*tv08 + $ + 1.526387027481200d-12*tv09 + $ - 1.226899454816980d-13*tv10 + $ - 2.848614761014972d-15*tv11 + $ + 1.880542777479446d-16*tv12 + HY3(0,-1,-1) = + $ + 3.816894981500984d-02 + $ + 1.039843750000000d-02*tv01 + $ + 3.828760080995617d-02*tv02 + $ + 3.466145833333333d-03*tv03 + $ + 1.185518160084905d-04*tv04 + $ - 9.904555648775859d-08*tv06 + $ + 1.331803984518588d-10*tv08 + $ - 2.006389465106708d-13*tv10 + $ + 3.180731062055677d-16*tv12 + endif + if ( nw.gt.3 ) then + HY4(0,0,0,-1) = + $ + 6.685228257646101d-02 + $ + 5.645990701998083d-01*tv01 + $ + 6.707912936340146d-02*tv02 + $ + 4.876429488624746d-03*tv03 + $ + 2.268732672568699d-04*tv04 + $ + 6.038494106229146d-06*tv05 + $ + 2.642577015932576d-08*tv06 + $ - 3.679843316593900d-09*tv07 + $ - 5.444046563879984d-11*tv08 + $ + 4.063821221202881d-12*tv09 + $ + 1.055985864474070d-13*tv10 + $ - 5.190408125225683d-15*tv11 + $ - 1.985464489219049d-16*tv12 + HY4(0,0,-1,-1) = + $ + 1.953236111099851d-02 + $ + 8.741612828671381d-03*tv01 + $ + 1.974116110893196d-02*tv02 + $ + 2.926558492394004d-03*tv03 + $ + 2.088576190269387d-04*tv04 + $ + 7.604351107741397d-06*tv05 + $ + 5.751031394942524d-08*tv06 + $ - 5.832253077603139d-09*tv07 + $ - 1.105713721511985d-10*tv08 + $ + 7.453416210082473d-12*tv09 + $ + 2.077758906032370d-13*tv10 + $ - 1.085601519719514d-14*tv11 + $ - 3.848312092795918d-16*tv12 + HY4(0,-1,-1,-1) = + $ + 7.148925781250000d-04 + $ + 7.019393481825299d-03*tv01 + $ + 9.531901041666666d-04*tv02 + $ + 2.354287493676137d-03*tv03 + $ + 2.382975260416666d-04*tv04 + $ + 8.682904829408987d-06*tv05 + $ - 7.768198634676578d-09*tv07 + $ + 1.083130072188330d-11*tv09 + $ - 1.668810490326842d-14*tv11 + endif +** nw > 3 endif + endif +** (n1,n2) = (-1,0) or (-1,1) endif +** (n1,n2) = (-1,1) -- completion + if ( (n1.eq.-1).and.(n2.eq.1) ) then + HY2(-1,1) = + $ - 2.924454241163343d-02 + $ + 3.845279287117326d-01*tu01 + $ - 2.925485694830038d-02*tu02 + $ + 1.097780471057338d-03*tu03 + $ - 1.029703135442673d-05*tu04 + $ - 7.265175511511970d-07*tu05 + $ + 1.747461299829753d-08*tu06 + $ + 7.707353556013722d-10*tu07 + $ - 3.064611747990741d-11*tu08 + $ - 8.531228176305706d-13*tu09 + $ + 5.331187822989144d-14*tu10 + $ + 8.500141365188675d-16*tu11 + $ - 6.931471805599453d-01*HY1(-1) + if ( nw.gt.2 ) then + HY3(0,-1,1) = + $ - 4.107537580582269d-02 + $ + 3.887609555197323d-01*tu01 + $ - 4.116162793629221d-02*tu02 + $ + 2.511526558054413d-03*tu03 + $ - 8.620496933228561d-05*tu04 + $ + 9.128023201466990d-07*tu05 + $ + 4.711634663963971d-08*tu06 + $ - 1.347359673414334d-09*tu07 + $ - 4.474345520888852d-11*tu08 + $ + 2.138249646727980d-12*tu09 + $ + 4.709915818801180d-14*tu10 + $ - 3.454431385666621d-15*tu11 + $ - 6.931471805599453d-01*HY2(0,-1) + HY3(0,1,-1) = + $ - 4.107537580582269d-02 + $ - 3.887609555197323d-01*tv01 + $ - 4.116162793629221d-02*tv02 + $ - 2.511526558054413d-03*tv03 + $ - 8.620496933228561d-05*tv04 + $ - 9.128023201466990d-07*tv05 + $ + 4.711634663963971d-08*tv06 + $ + 1.347359673414334d-09*tv07 + $ - 4.474345520888852d-11*tv08 + $ - 2.138249646727980d-12*tv09 + $ + 4.709915818801180d-14*tv10 + $ + 3.454431385666621d-15*tv11 + $ + 6.931471805599453d-01*HY2(0,1) + HY3(-1,-1,1) = + $ - 3.590863871372201d-02 + $ + 3.272029419300922d-01*tu01 + $ - 3.599657175069328d-02*tu02 + $ + 2.325685169395631d-03*tu03 + $ - 8.788997314012583d-05*tu04 + $ + 1.277831858501559d-06*tu05 + $ + 4.303730428865162d-08*tu06 + $ - 1.992295216809703d-09*tu07 + $ - 2.652932076676834d-11*tu08 + $ + 3.159865930142703d-12*tu09 + $ - 2.395589527593406d-15*tu10 + $ - 4.870947810519399d-15*tu11 + $ - 5.822405264650125d-01*HY1(-1) + $ - 3.465735902799726d-01*HY1(-1)*HY1(-1) + HY3(-1,1,1) = + $ + 3.668493142404161d-02 + $ - 1.413123104773291d-01*tu01 + $ + 3.680167312678666d-02*tu02 + $ - 3.064044728536094d-03*tu03 + $ + 1.166524199994130d-04*tu04 + $ - 8.779983417383380d-07*tu05 + $ - 8.917940330502000d-08*tu06 + $ + 1.787575622706040d-09*tu07 + $ + 1.032182649980912d-10*tu08 + $ - 3.441821872732193d-12*tu09 + $ - 1.239218730863368d-13*tu10 + $ + 6.355731482672869d-15*tu11 + $ + 1.386175839607904d-16*tu12 + $ + 2.402265069591007d-01*HY1(-1) + endif + if ( nw.gt.3 ) then + HY4(0,0,-1,1) = + $ - 4.713463351559199d-02 + $ + 3.918037828258655d-01*tu01 + $ - 4.730698763577787d-02*tu02 + $ + 3.532784273601097d-03*tu03 + $ - 1.724036773635937d-04*tu04 + $ + 5.100573466380115d-06*tu05 + $ - 4.948996960052575d-08*tu06 + $ - 2.345390965359666d-09*tu07 + $ + 6.710522628543514d-11*tu08 + $ + 1.979867116023822d-12*tu09 + $ - 1.027163441987459d-13*tu10 + $ - 1.836436639605094d-15*tu11 + $ + 1.633620651699784d-16*tu12 + $ - 6.931471805599453d-01*HY3(0,0,-1) + HY4(0,0,1,-1) = + $ - 4.713463351559199d-02 + $ - 3.918037828258655d-01*tv01 + $ - 4.730698763577787d-02*tv02 + $ - 3.532784273601097d-03*tv03 + $ - 1.724036773635937d-04*tv04 + $ - 5.100573466380115d-06*tv05 + $ - 4.948996960052575d-08*tv06 + $ + 2.345390965359666d-09*tv07 + $ + 6.710522628543514d-11*tv08 + $ - 1.979867116023822d-12*tv09 + $ - 1.027163441987459d-13*tv10 + $ + 1.836436639605094d-15*tv11 + $ + 1.633620651699784d-16*tv12 + $ + 6.931471805599453d-01*HY3(0,0,1) + HY4(0,-1,0,1) = + $ - 5.610575179941452d-02 + $ + 4.649892609082033d-01*tu01 + $ - 5.631239161843284d-02*tu02 + $ + 4.220972769653239d-03*tu03 + $ - 2.066940413626322d-04*tu04 + $ + 6.100628682175971d-06*tu05 + $ - 5.412969106099992d-08*tu06 + $ - 3.230915912784154d-09*tu07 + $ + 9.249866333323043d-11*tu08 + $ + 2.685990764581699d-12*tu09 + $ - 1.543312114608473d-13*tu10 + $ - 2.036971731594398d-15*tu11 + $ + 2.517450307574790d-16*tu12 + $ - 8.224670334241132d-01*HY2(0,-1) + HY4(0,-1,-1,1) = + $ - 4.031271939759038d-02 + $ + 3.295217254379970d-01*tu01 + $ - 4.047097737450547d-02*tu02 + $ + 3.104955391145708d-03*tu03 + $ - 1.583251510732719d-04*tu04 + $ + 5.083334568184305d-06*tu05 + $ - 6.708598619683341d-08*tu06 + $ - 1.944278941559733d-09*tu07 + $ + 8.804863765356287d-11*tu08 + $ + 9.341312729419985d-13*tu09 + $ - 1.231746977889946d-13*tu10 + $ + 3.370647349658755d-16*tu11 + $ + 1.718647072955689d-16*tu12 + $ - 5.822405264650125d-01*HY2(0,-1) + $ - 6.931471805599453d-01*HY3(0,-1,-1) + HY4(0,-1,1,-1) = + $ - 4.495764739674318d-02 + $ - 2.758514579198452d-01*tv01 + $ - 4.515130668959398d-02*tv02 + $ - 3.875995092451054d-03*tv03 + $ - 1.936768370518385d-04*tv04 + $ - 5.133195476137788d-06*tv05 + $ - 1.752786900562004d-08*tv06 + $ + 2.715518363893619d-09*tv07 + $ + 1.631155670579918d-11*tv08 + $ - 2.940721244025822d-12*tv09 + $ - 2.045219059123054d-14*tv10 + $ + 3.895696592051861d-15*tv11 + $ + 4.804530139182014d-01*HY2(0,-1) + $ + 6.931471805599453d-01*HY3(0,-1,1) + HY4(0,1,-1,-1) = + $ - 2.782664607935622d-02 + $ - 1.410831481728889d-01*tv01 + $ - 2.801876266982354d-02*tv02 + $ - 2.997894208020603d-03*tv03 + $ - 1.921960113936824d-04*tv04 + $ - 7.016503666427137d-06*tv05 + $ - 7.928257765061337d-08*tv06 + $ + 4.388745575295455d-09*tv07 + $ + 1.381107719492586d-10*tv08 + $ - 4.341921500497716d-12*tv09 + $ - 2.375364913875066d-13*tv10 + $ + 4.522044546598701d-15*tv11 + $ + 4.033357472727688d-16*tv12 + $ + 2.402265069591007d-01*HY2(0,1) + HY4(0,-1,1,1) = + $ + 2.782664607935622d-02 + $ - 1.410831481728889d-01*tu01 + $ + 2.801876266982354d-02*tu02 + $ - 2.997894208020603d-03*tu03 + $ + 1.921960113936824d-04*tu04 + $ - 7.016503666427137d-06*tu05 + $ + 7.928257765061337d-08*tu06 + $ + 4.388745575295455d-09*tu07 + $ - 1.381107719492586d-10*tu08 + $ - 4.341921500497716d-12*tu09 + $ + 2.375364913875066d-13*tu10 + $ + 4.522044546598701d-15*tu11 + $ - 4.033357472727688d-16*tu12 + $ + 2.402265069591007d-01*HY2(0,-1) + HY4(0,1,-1,1) = + $ + 4.495764739674318d-02 + $ - 2.758514579198452d-01*tu01 + $ + 4.515130668959398d-02*tu02 + $ - 3.875995092451054d-03*tu03 + $ + 1.936768370518385d-04*tu04 + $ - 5.133195476137788d-06*tu05 + $ + 1.752786900562004d-08*tu06 + $ + 2.715518363893619d-09*tu07 + $ - 1.631155670579918d-11*tu08 + $ - 2.940721244025822d-12*tu09 + $ + 2.045219059123054d-14*tu10 + $ + 3.895696592051861d-15*tu11 + $ + 4.804530139182014d-01*HY2(0,1) + $ - 6.931471805599453d-01*HY3(0,1,-1) + HY4(0,1,1,-1) = + $ + 4.031271939759038d-02 + $ + 3.295217254379970d-01*tv01 + $ + 4.047097737450547d-02*tv02 + $ + 3.104955391145708d-03*tv03 + $ + 1.583251510732719d-04*tv04 + $ + 5.083334568184305d-06*tv05 + $ + 6.708598619683341d-08*tv06 + $ - 1.944278941559733d-09*tv07 + $ - 8.804863765356287d-11*tv08 + $ + 9.341312729419985d-13*tv09 + $ + 1.231746977889946d-13*tv10 + $ + 3.370647349658755d-16*tv11 + $ - 1.718647072955689d-16*tv12 + $ - 5.822405264650125d-01*HY2(0,1) + $ + 6.931471805599453d-01*HY3(0,1,1) + HY4(-1,-1,-1,1) = + $ - 3.768651335815766d-02 + $ + 3.043162147119780d-01*tu01 + $ - 3.784162844891144d-02*tu02 + $ + 2.958351024362477d-03*tu03 + $ - 1.551924666783514d-04*tu04 + $ + 5.216293832777793d-06*tu05 + $ - 7.726843592398867d-08*tu06 + $ - 1.910379383726989d-09*tu07 + $ + 1.073377838077624d-10*tu08 + $ + 4.147979000313175d-13*tu09 + $ - 1.506593045440627d-13*tu10 + $ + 1.921276747438603d-15*tu11 + $ + 1.977332880766160d-16*tu12 + $ - 5.372131936080402d-01*HY1(-1) + $ - 2.911202632325062d-01*HY1(-1)*HY1(-1) + $ - 1.155245300933242d-01*HY1(-1)*HY1(-1)*HY1(-1) + HY4(-1,-1,1,1) = + $ + 2.908893189635991d-02 + $ - 1.784837106345115d-01*tu01 + $ + 2.927117884632272d-02*tu02 + $ - 2.888221776586007d-03*tu03 + $ + 1.823501630828519d-04*tu04 + $ - 6.976883920991888d-06*tu05 + $ + 1.030302948541690d-07*tu06 + $ + 3.794029548474434d-09*tu07 + $ - 1.825184393299693d-10*tu08 + $ - 2.300206200729610d-12*tu09 + $ + 3.062629564489397d-13*tu10 + $ - 7.629393984387632d-16*tu11 + $ - 4.860728618463296d-16*tu12 + $ + 3.088253750968339d-01*HY1(-1) + $ + 1.201132534795503d-01*HY1(-1)*HY1(-1) + HY4(-1,1,1,1) = + $ - 9.029205146496301d-03 + $ + 3.753824045412342d-02*tu01 + $ - 9.240717745810759d-03*tu02 + $ + 2.351153976182453d-03*tu03 + $ - 2.115782190216214d-04*tu04 + $ + 8.486524807740892d-06*tu05 + $ - 6.547885807612483d-08*tu06 + $ - 6.934422754020238d-09*tu07 + $ + 1.405695202725693d-10*tu08 + $ + 8.329441237576153d-12*tu09 + $ - 2.790404594803712d-13*tu10 + $ - 1.024489568815216d-14*tu11 + $ + 5.256388245544115d-16*tu12 + $ - 5.550410866482157d-02*HY1(-1) + endif +** nw > 3 endif + endif +** (n1,n2) = (-1,1) -- completion endif + return + end +************************************************************************ + subroutine fillirr1dhplat1(r,nw,HR1,HR2,HR3,HR4, + $ HY1,HY2,HY3,HY4, + $ Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates the HPL for r2m1 < y < r2p1 +** fillirr1dhplat1 is called by eval1dhplat1 after calling +** fillirr1dhplat0 with argument r=(1-y)/(1+y) +** it is guaranteed that nw is in the range 2:4, and that (n1,n2) +** take one of the pairs of values (0,1), (-1,0) or (-1,1) + implicit double precision (a-h,o-z) + dimension HR1(-1:1),HR2(-1:1,-1:1),HR3(-1:1,-1:1,-1:1), + $ HR4(-1:1,-1:1,-1:1,-1:1) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) +** (n1,n2) = (0,1) or (-1,1) + if ( ( (n1.eq.0).and.(n2.eq.1) ) + $ .or.( (n1.eq.-1).and.(n2.eq.1) ) ) then + HY2(0,1) = + $ + 1.6449340668482264d+00 + $ + 6.9314718055994530d-01*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1) + $ + HR1( -1)*HR1(0) + $ - HR1( -1)*HR1(1) + $ + HR1(0) *HR1(1) + $ + 6.9314718055994530d-01*HR1(1) + $ + HR2( -1,1) + $ - HR2(0, -1) + $ - HR2(0,1) + if (r.lt.0d0) then + Hi2(0,1) = + $ - HR1( -1) + $ - HR1(1) + endif + if ( nw.gt.2 ) then + HY3(0,0,1) = + $ + 1.2020569031595942d+00 + $ - 1.6449340668482264d+00*HR1(-1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - HR1( -1)*HR1(0)*HR1(1) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(1)*HR1(1) + $ + HR1( -1)*HR2(0,-1) + $ + HR1( -1)*HR2(0,1) + $ - 5.0000000000000000d-01*HR1(0)*HR1(1)*HR1(1) + $ - 1.6449340668482264d+00*HR1(1) + $ - 3.4657359027997265d-01*HR1(1)*HR1(1) + $ - HR1(1) *HR2(-1,1) + $ + HR1(1) *HR2(0,-1) + $ + HR1(1) *HR2(0,1) + $ - HR3( -1,-1,1) + $ + HR3( -1,1,1) + $ - HR3(0, -1,-1) + $ - HR3(0, -1,1) + $ - HR3(0,1, -1) + $ - HR3(0,1,1) + HY3(0,1,1) = + $ + 1.2020569031595942d+00 + $ - 2.4022650695910071d-01*HR1(-1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(0) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(0) + $ + HR1( -1)*HR1(0)*HR1(1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ + HR1( -1)*HR2(-1,1) + $ - 5.0000000000000000d-01*HR1(0)*HR1(0)*HR1(1) + $ - 6.9314718055994530d-01*HR1(0)*HR1(1) + $ - HR1(0) *HR2(-1,1) + $ + HR1(0) *HR2(0,-1) + $ + HR1(0) *HR2(0,1) + $ - 2.4022650695910071d-01*HR1(1) + $ - 6.9314718055994530d-01*HR2(-1,1) + $ + 6.9314718055994530d-01*HR2(0,-1) + $ + 6.9314718055994530d-01*HR2(0,1) + $ - HR3( -1,-1,1) + $ - HR3(0, -1,-1) + $ - HR3(0,0, -1) + $ - HR3(0,0,1) + $ - HR3(0,1, -1) + if (r.lt.0d0) then + HY3(0,1,1) = HY3(0,1,1) + $ + 4.9348022005446793d+00*HR1(-1) + $ + 4.9348022005446793d+00*HR1(1) + Hi3(0,0,1) = + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1) + $ + HR1( -1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(1)*HR1(1) + Hi3(0,1,1) = + $ + 6.9314718055994530d-01*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1) + $ + HR1( -1)*HR1(0) + $ - HR1( -1)*HR1(1) + $ + HR1(0) *HR1(1) + $ + 6.9314718055994530d-01*HR1(1) + $ + HR2( -1,1) + $ - HR2(0, -1) + $ - HR2(0,1) + endif + endif + if ( nw.gt.3 ) then + HY4(0,0,0,1) = + $ + 1.0823232337111381d+00 + $ - 1.2020569031595942d+00*HR1(-1) + $ + 8.2246703342411321d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(1)*HR1(1) + $ + 1.6449340668482264d+00*HR1(-1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(1)*HR1(1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(1)*HR1(1)*HR1(1) + $ - HR1( -1)*HR1(1)*HR2(0,-1) + $ - HR1( -1)*HR1(1)*HR2(0,1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + HR1( -1)*HR3(0,-1,1) + $ + HR1( -1)*HR3(0,1,-1) + $ + HR1( -1)*HR3(0,1,1) + $ + 1.6666666666666666d-01*HR1(0)*HR1(1)*HR1(1)*HR1(1) + $ - 1.2020569031595942d+00*HR1(1) + $ + 8.2246703342411321d-01*HR1(1)*HR1(1) + $ + 1.1552453009332421d-01*HR1(1)*HR1(1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(1)*HR1(1)*HR2(-1,1) + $ - 5.0000000000000000d-01*HR1(1)*HR1(1)*HR2(0,-1) + $ - 5.0000000000000000d-01*HR1(1)*HR1(1)*HR2(0,1) + $ + HR1(1) *HR3(-1,-1,1) + $ - HR1(1) *HR3(-1,1,1) + $ + HR1(1) *HR3(0,-1,-1) + $ + HR1(1) *HR3(0,-1,1) + $ + HR1(1) *HR3(0,1,-1) + $ + HR1(1) *HR3(0,1,1) + $ + HR4( -1,-1,-1,1) + $ - HR4( -1,-1,1,1) + $ + HR4( -1,1,1,1) + $ - HR4(0, -1,-1,-1) + $ - HR4(0, -1,-1,1) + $ - HR4(0, -1,1,-1) + $ - HR4(0, -1,1,1) + $ - HR4(0,1, -1,-1) + $ - HR4(0,1, -1,1) + $ - HR4(0,1,1, -1) + $ - HR4(0,1,1,1) + HY4(0,0,1,1) = + $ + 2.7058080842778454d-01 + $ - 1.2020569031595942d+00*HR1(-1) + $ + 1.2011325347955035d-01*HR1(-1)*HR1(-1) + $ - 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(0) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(0)*HR1(1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(0)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(1)*HR1(1) + $ - HR1( -1)*HR1(0)*HR2(0,-1) + $ - HR1( -1)*HR1(0)*HR2(0,1) + $ + 2.4022650695910071d-01*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(1)*HR1(1) + $ - HR1( -1)*HR1(1)*HR2(-1,1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(0,1) + $ - HR1( -1)*HR3(-1,-1,1) + $ + HR1( -1)*HR3(-1,1,1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + HR1( -1)*HR3(0,0,-1) + $ + HR1( -1)*HR3(0,0,1) + $ + HR1( -1)*HR3(0,1,-1) + $ + 2.5000000000000000d-01*HR1(0)*HR1(0)*HR1(1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(0)*HR1(1)*HR1(1) + $ + HR1(0) *HR1(1)*HR2(-1,1) + $ - HR1(0) *HR1(1)*HR2(0,-1) + $ - HR1(0) *HR1(1)*HR2(0,1) + $ + HR1(0) *HR3(-1,-1,1) + $ - HR1(0) *HR3(-1,1,1) + $ + HR1(0) *HR3(0,-1,-1) + $ + HR1(0) *HR3(0,-1,1) + $ + HR1(0) *HR3(0,1,-1) + $ + HR1(0) *HR3(0,1,1) + $ - 1.2020569031595942d+00*HR1(1) + $ + 1.2011325347955035d-01*HR1(1)*HR1(1) + $ + 6.9314718055994530d-01*HR1(1)*HR2(-1,1) + $ - 6.9314718055994530d-01*HR1(1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(1)*HR2(0,1) + $ + HR1(1) *HR3(-1,-1,1) + $ + HR1(1) *HR3(0,-1,-1) + $ + HR1(1) *HR3(0,0,-1) + $ + HR1(1) *HR3(0,0,1) + $ + HR1(1) *HR3(0,1,-1) + $ + 6.9314718055994530d-01*HR3(-1,-1,1) + $ - 6.9314718055994530d-01*HR3(-1,1,1) + $ + 6.9314718055994530d-01*HR3(0,-1,-1) + $ + 6.9314718055994530d-01*HR3(0,-1,1) + $ + 6.9314718055994530d-01*HR3(0,1,-1) + $ + 6.9314718055994530d-01*HR3(0,1,1) + $ + 2.0000000000000000d+00*HR4(-1,-1,-1,1) + $ - HR4( -1,-1,1,1) + $ - 2.0000000000000000d+00*HR4(0,-1,-1,-1) + $ - HR4(0, -1,-1,1) + $ - HR4(0, -1,1,-1) + $ - HR4(0,0, -1,-1) + $ - HR4(0,0, -1,1) + $ - HR4(0,0,1, -1) + $ - HR4(0,0,1,1) + $ - 2.0000000000000000d+00*HR4(0,1,-1,-1) + $ - HR4(0,1, -1,1) + $ - HR4(0,1,1, -1) + HY4(0,1,1,1) = + $ + 1.0823232337111381d+00 + $ + 5.5504108664821579d-02*HR1(-1) + $ - 1.2011325347955035d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(0) + $ - 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(0) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ + 2.4022650695910071d-01*HR1(-1)*HR1(0) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(0)*HR1(0) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(0)*HR1(0)*HR1(0) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(0)*HR1(1) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(0)*HR1(1) + $ - HR1( -1)*HR1(0)*HR2(-1,1) + $ - 2.4022650695910071d-01*HR1(-1)*HR1(1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ - HR1( -1)*HR3(-1,-1,1) + $ + 1.6666666666666666d-01*HR1(0)*HR1(0)*HR1(0)*HR1(1) + $ + 3.4657359027997265d-01*HR1(0)*HR1(0)*HR1(1) + $ + 5.0000000000000000d-01*HR1(0)*HR1(0)*HR2(-1,1) + $ - 5.0000000000000000d-01*HR1(0)*HR1(0)*HR2(0,-1) + $ - 5.0000000000000000d-01*HR1(0)*HR1(0)*HR2(0,1) + $ + 2.4022650695910071d-01*HR1(0)*HR1(1) + $ + 6.9314718055994530d-01*HR1(0)*HR2(-1,1) + $ - 6.9314718055994530d-01*HR1(0)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(0)*HR2(0,1) + $ + HR1(0) *HR3(-1,-1,1) + $ + HR1(0) *HR3(0,-1,-1) + $ + HR1(0) *HR3(0,0,-1) + $ + HR1(0) *HR3(0,0,1) + $ + HR1(0) *HR3(0,1,-1) + $ + 5.5504108664821579d-02*HR1(1) + $ + 2.4022650695910071d-01*HR2(-1,1) + $ - 2.4022650695910071d-01*HR2(0,-1) + $ - 2.4022650695910071d-01*HR2(0,1) + $ + 6.9314718055994530d-01*HR3(-1,-1,1) + $ + 6.9314718055994530d-01*HR3(0,-1,-1) + $ + 6.9314718055994530d-01*HR3(0,0,-1) + $ + 6.9314718055994530d-01*HR3(0,0,1) + $ + 6.9314718055994530d-01*HR3(0,1,-1) + $ + HR4( -1,-1,-1,1) + $ - HR4(0, -1,-1,-1) + $ - HR4(0,0, -1,-1) + $ - HR4(0,0,0, -1) + $ - HR4(0,0,0,1) + $ - HR4(0,0,1, -1) + $ - HR4(0,1, -1,-1) + if (r.lt.0d0) then + HY4(0,0,1,1) = HY4(0,0,1,1) + $ - 2.4674011002723396d+00*HR1(-1)*HR1(-1) + $ - 4.9348022005446793d+00*HR1(-1)*HR1(1) + $ - 2.4674011002723396d+00*HR1(1)*HR1(1) + HY4(0,1,1,1) = HY4(0,1,1,1) + $ - 3.4205442319285582d+00*HR1(-1) + $ + 2.4674011002723396d+00*HR1(-1)*HR1(-1) + $ - 4.9348022005446793d+00*HR1(-1)*HR1(0) + $ + 4.9348022005446793d+00*HR1(-1)*HR1(1) + $ - 4.9348022005446793d+00*HR1(0)*HR1(1) + $ - 3.4205442319285582d+00*HR1(1) + $ - 4.9348022005446793d+00*HR2(-1,1) + $ + 4.9348022005446793d+00*HR2(0,-1) + $ + 4.9348022005446793d+00*HR2(0,1) + Hi4(0,0,0,1) = + $ - 1.666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 5.000000000000000d-01*HR1(-1)*HR1(1)*HR1(1) + $ - 1.666666666666666d-01*HR1(1)*HR1(1)*HR1(1) + Hi4(0,0,1,1) = + $ - 3.465735902799726d-01*HR1(-1)*HR1(-1) + $ + 1.666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 5.000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - HR1( -1)*HR1(0)*HR1(1) + $ - 6.931471805599453d-01*HR1(-1)*HR1(1) + $ + 5.000000000000000d-01*HR1(-1)*HR1(1)*HR1(1) + $ + HR1( -1)*HR2(0,-1) + $ + HR1( -1)*HR2(0,1) + $ - 5.000000000000000d-01*HR1(0)*HR1(1)*HR1(1) + $ - 3.465735902799726d-01*HR1(1)*HR1(1) + $ - HR1(1) *HR2(-1,1) + $ + HR1(1) *HR2(0,-1) + $ + HR1(1) *HR2(0,1) + $ - HR3( -1,-1,1) + $ + HR3( -1,1,1) + $ - HR3(0, -1,-1) + $ - HR3(0, -1,1) + $ - HR3(0,1, -1) + $ - HR3(0,1,1) + Hi4(0,1,1,1) = + $ + 1.404707559889125d+00*HR1(-1) + $ + 3.465735902799726d-01*HR1(-1)*HR1(-1) + $ - 1.666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 5.000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ - 5.000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 6.931471805599453d-01*HR1(-1)*HR1(0) + $ - 5.000000000000000d-01*HR1(-1)*HR1(0)*HR1(0) + $ + HR1( -1)*HR1(0)*HR1(1) + $ + 6.931471805599453d-01*HR1(-1)*HR1(1) + $ + HR1( -1)*HR2(-1,1) + $ - 5.000000000000000d-01*HR1(0)*HR1(0)*HR1(1) + $ - 6.931471805599453d-01*HR1(0)*HR1(1) + $ - HR1(0) *HR2(-1,1) + $ + HR1(0) *HR2(0,-1) + $ + HR1(0) *HR2(0,1) + $ + 1.404707559889125d+00*HR1(1) + $ - 6.931471805599453d-01*HR2(-1,1) + $ + 6.931471805599453d-01*HR2(0,-1) + $ + 6.931471805599453d-01*HR2(0,1) + $ - HR3( -1,-1,1) + $ - HR3(0, -1,-1) + $ - HR3(0,0, -1) + $ - HR3(0,0,1) + $ - HR3(0,1, -1) + endif + endif +** nw > 3 endif + endif +** (n1,n2) = (0,1) or (-1,1) endif +************ +** (n1,n2) = (-1,0) or (-1,1) + if ( ( (n1.eq.-1).and.(n2.eq.0) ) + $ .or.( (n1.eq.-1).and.(n2.eq.1) ) ) then + HY2(0,-1) = + $ + 8.2246703342411321d-01 + $ - 6.9314718055994530d-01*HR1(-1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1) + $ + HR1( -1)*HR1(1) + $ - 6.9314718055994530d-01*HR1(1) + $ - HR2( -1,1) + if ( nw.gt.2 ) then + HY3(0,0,-1) = + $ + 9.0154267736969571d-01 + $ - 8.2246703342411321d-01*HR1(-1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(1)*HR1(1) + $ - 8.2246703342411321d-01*HR1(1) + $ + 3.4657359027997265d-01*HR1(1)*HR1(1) + $ + HR1(1) *HR2(-1,1) + $ + HR3( -1,-1,1) + $ - HR3( -1,1,1) + HY3(0,-1,-1) = + $ + 1.5025711289494928d-01 + $ - 2.4022650695910071d-01*HR1(-1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ + HR1( -1)*HR2(-1,1) + $ - 2.4022650695910071d-01*HR1(1) + $ - 6.9314718055994530d-01*HR2(-1,1) + $ - HR3( -1,-1,1) + endif + if ( nw.gt.3 ) then + HY4(0,0,0,-1) = + $ + 9.4703282949724591d-01 + $ - 9.0154267736969571d-01*HR1(-1) + $ + 4.1123351671205660d-01*HR1(-1)*HR1(-1) + $ - 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1)*HR1(1) + $ + 8.2246703342411321d-01*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(1)*HR1(1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(1)*HR1(1)*HR1(1) + $ - 9.0154267736969571d-01*HR1(1) + $ + 4.1123351671205660d-01*HR1(1)*HR1(1) + $ - 1.1552453009332421d-01*HR1(1)*HR1(1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(1)*HR1(1)*HR2(-1,1) + $ - HR1(1) *HR3(-1,-1,1) + $ + HR1(1) *HR3(-1,1,1) + $ - HR4( -1,-1,-1,1) + $ + HR4( -1,-1,1,1) + $ - HR4( -1,1,1,1) + HY4(0,0,-1,-1) = + $ + 8.7785671568655302d-02 + $ - 1.5025711289494928d-01*HR1(-1) + $ + 1.2011325347955035d-01*HR1(-1)*HR1(-1) + $ - 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1)*HR1(1) + $ + 2.4022650695910071d-01*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(1)*HR1(1) + $ - HR1( -1)*HR1(1)*HR2(-1,1) + $ - HR1( -1)*HR3(-1,-1,1) + $ + HR1( -1)*HR3(-1,1,1) + $ - 1.5025711289494928d-01*HR1(1) + $ + 1.2011325347955035d-01*HR1(1)*HR1(1) + $ + 6.9314718055994530d-01*HR1(1)*HR2(-1,1) + $ + HR1(1) *HR3(-1,-1,1) + $ + 6.9314718055994530d-01*HR3(-1,-1,1) + $ - 6.9314718055994530d-01*HR3(-1,1,1) + $ + 2.0000000000000000d+00*HR4(-1,-1,-1,1) + $ - HR4( -1,-1,1,1) + HY4(0,-1,-1,-1) = + $ + 2.3752366322618485d-02 + $ - 5.5504108664821579d-02*HR1(-1) + $ + 1.2011325347955035d-01*HR1(-1)*HR1(-1) + $ - 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ + 2.4022650695910071d-01*HR1(-1)*HR1(1) + $ + 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ + HR1( -1)*HR3(-1,-1,1) + $ - 5.5504108664821579d-02*HR1(1) + $ - 2.4022650695910071d-01*HR2(-1,1) + $ - 6.9314718055994530d-01*HR3(-1,-1,1) + $ - HR4( -1,-1,-1,1) + endif +** nw > 3 endif + endif +** (n1,n2) = (-1,0) or (-1,1) endif +** (n1,n2) = (-1,1) -- completion + if ( (n1.eq.-1).and.(n2.eq.1) ) then + HY2(-1,1) = + $ + 5.8224052646501250d-01 + $ + 6.9314718055994530d-01*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1) + $ + HR1( -1)*HR1(0) + $ - HR2(0, -1) + if (r.lt.0d0) then + Hi2(-1,1) = + $ - HR1( -1) + endif + if ( nw.gt.2 ) then + HY3(0,-1,1) = + $ + 2.4307035167006157d-01 + $ - 5.8224052646501250d-01*HR1(-1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - HR1( -1)*HR1(0)*HR1(1) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ - HR1( -1)*HR2(-1,1) + $ + HR1( -1)*HR2(0,-1) + $ + HR1(0) *HR2(-1,1) + $ - 5.8224052646501250d-01*HR1(1) + $ + HR1(1) *HR2(0,-1) + $ + 6.9314718055994530d-01*HR2(-1,1) + $ + HR3( -1,-1,1) + $ - HR3(0, -1,-1) + $ - HR3(0, -1,1) + HY3(0,1,-1) = + $ + 5.0821521280468485d-01 + $ + 1.0626935403832139d+00*HR1(-1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(0) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ - HR1( -1)*HR2(-1,1) + $ - HR1( -1)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR1(0)*HR1(1) + $ + 1.0626935403832139d+00*HR1(1) + $ - HR1(1) *HR2(0,-1) + $ + 6.9314718055994530d-01*HR2(-1,1) + $ - 6.9314718055994530d-01*HR2(0,-1) + $ - 6.9314718055994530d-01*HR2(0,1) + $ + HR3( -1,-1,1) + $ + 2.0000000000000000d+00*HR3(0,-1,-1) + $ + HR3(0, -1,1) + $ + HR3(0,1, -1) + HY3(-1,-1,1) = + $ + 9.4753004230127705d-02 + $ - 5.8224052646501250d-01*HR1(-1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + HR1( -1)*HR2(0,-1) + $ - HR3(0, -1,-1) + HY3(-1,1,1) = + $ + 5.3721319360804020d-01 + $ - 2.4022650695910071d-01*HR1(-1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(0) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(0) + $ + HR1(0) *HR2(0,-1) + $ + 6.9314718055994530d-01*HR2(0,-1) + $ - HR3(0, -1,-1) + $ - HR3(0,0, -1) + if (r.lt.0d0) then + HY3(-1,1,1) = HY3(-1,1,1) + $ + 4.9348022005446793d+00*HR1(-1) + Hi3(0,-1,1) = + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1) + $ + HR1( -1)*HR1(1) + $ - HR2( -1,1) + Hi3(0,1,-1) = + $ - 6.9314718055994530d-01*HR1(-1) + $ - 6.9314718055994530d-01*HR1(1) + Hi3(-1,-1,1) = + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1) + Hi3(-1,1,1) = + $ + 6.9314718055994530d-01*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1) + $ + HR1( -1)*HR1(0) + $ - HR2(0, -1) + endif + endif + if ( nw.gt.3 ) then + HY4(0,0,-1,1) = + $ + 1.1787599965050932d-01 + $ - 2.4307035167006157d-01*HR1(-1) + $ + 2.9112026323250625d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(1)*HR1(1) + $ + 5.8224052646501250d-01*HR1(-1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(1)*HR1(1) + $ + HR1( -1)*HR1(1)*HR2(-1,1) + $ - HR1( -1)*HR1(1)*HR2(0,-1) + $ + HR1( -1)*HR3(-1,-1,1) + $ - HR1( -1)*HR3(-1,1,1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + HR1( -1)*HR3(0,-1,1) + $ - HR1(0) *HR1(1)*HR2(-1,1) + $ - HR1(0) *HR3(-1,-1,1) + $ + HR1(0) *HR3(-1,1,1) + $ - 2.4307035167006157d-01*HR1(1) + $ + 2.9112026323250625d-01*HR1(1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(1)*HR1(1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(1)*HR2(-1,1) + $ - HR1(1) *HR3(-1,-1,1) + $ + HR1(1) *HR3(0,-1,-1) + $ + HR1(1) *HR3(0,-1,1) + $ - 6.9314718055994530d-01*HR3(-1,-1,1) + $ + 6.9314718055994530d-01*HR3(-1,1,1) + $ - 2.0000000000000000d+00*HR4(-1,-1,-1,1) + $ + HR4( -1,-1,1,1) + $ - HR4(0, -1,-1,-1) + $ - HR4(0, -1,-1,1) + $ - HR4(0, -1,1,-1) + $ - HR4(0, -1,1,1) + HY4(0,0,1,-1) = + $ + 1.7284527823898438d-01 + $ - 5.0821521280468485d-01*HR1(-1) + $ - 5.3134677019160696d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(0)*HR1(1) + $ - 1.0626935403832139d+00*HR1(-1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(1)*HR1(1) + $ + HR1( -1)*HR1(1)*HR2(-1,1) + $ + HR1( -1)*HR1(1)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR1(-1)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR1(-1)*HR2(0,1) + $ + HR1( -1)*HR3(-1,-1,1) + $ - HR1( -1)*HR3(-1,1,1) + $ - 2.0000000000000000d+00*HR1(-1)*HR3(0,-1,-1) + $ - HR1( -1)*HR3(0,-1,1) + $ - HR1( -1)*HR3(0,1,-1) + $ - 3.4657359027997265d-01*HR1(0)*HR1(1)*HR1(1) + $ - 5.0821521280468485d-01*HR1(1) + $ - 5.3134677019160696d-01*HR1(1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(1)*HR1(1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(1)*HR2(-1,1) + $ + 6.9314718055994530d-01*HR1(1)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR1(1)*HR2(0,1) + $ - HR1(1) *HR3(-1,-1,1) + $ - 2.0000000000000000d+00*HR1(1)*HR3(0,-1,-1) + $ - HR1(1) *HR3(0,-1,1) + $ - HR1(1) *HR3(0,1,-1) + $ - 6.9314718055994530d-01*HR3(-1,-1,1) + $ + 6.9314718055994530d-01*HR3(-1,1,1) + $ - 6.9314718055994530d-01*HR3(0,-1,-1) + $ - 6.9314718055994530d-01*HR3(0,-1,1) + $ - 6.9314718055994530d-01*HR3(0,1,-1) + $ - 6.9314718055994530d-01*HR3(0,1,1) + $ - 2.0000000000000000d+00*HR4(-1,-1,-1,1) + $ + HR4( -1,-1,1,1) + $ + 3.0000000000000000d+00*HR4(0,-1,-1,-1) + $ + 2.0000000000000000d+00*HR4(0,-1,-1,1) + $ + 2.0000000000000000d+00*HR4(0,-1,1,-1) + $ + HR4(0, -1,1,1) + $ + 2.0000000000000000d+00*HR4(0,1,-1,-1) + $ + HR4(0,1, -1,1) + $ + HR4(0,1,1, -1) + HY4(0,-1,0,1) = + $ + 2.0293560632083841d-01 + $ - 3.8889584616810632d-01*HR1(-1) + $ + 8.2246703342411321d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,1) + $ - HR1( -1)*HR1(0)*HR2(-1,1) + $ + 1.6449340668482264d+00*HR1(-1)*HR1(1) + $ - HR1( -1)*HR1(1)*HR2(-1,1) + $ - HR1( -1)*HR1(1)*HR2(0,-1) + $ - HR1( -1)*HR1(1)*HR2(0,1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ - 2.0000000000000000d+00*HR1(-1)*HR3(-1,-1,1) + $ + 2.0000000000000000d+00*HR1(-1)*HR3(-1,1,1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + HR1( -1)*HR3(0,1,-1) + $ + HR1(0) *HR1(1)*HR2(-1,1) + $ + 2.0000000000000000d+00*HR1(0)*HR3(-1,-1,1) + $ - 2.0000000000000000d+00*HR1(0)*HR3(-1,1,1) + $ - 3.8889584616810632d-01*HR1(1) + $ + 6.9314718055994530d-01*HR1(1)*HR2(-1,1) + $ + 2.0000000000000000d+00*HR1(1)*HR3(-1,-1,1) + $ + HR1(1) *HR3(0,-1,-1) + $ + HR1(1) *HR3(0,1,-1) + $ - 1.6449340668482264d+00*HR2(-1,1) + $ - 5.0000000000000000d-01*HR2(-1,1)*HR2(-1,1) + $ + HR2( -1,1)*HR2(0,-1) + $ + HR2( -1,1)*HR2(0,1) + $ + 1.3862943611198906d+00*HR3(-1,-1,1) + $ - 1.3862943611198906d+00*HR3(-1,1,1) + $ + 4.0000000000000000d+00*HR4(-1,-1,-1,1) + $ - 2.0000000000000000d+00*HR4(-1,-1,1,1) + $ - HR4(0, -1,-1,-1) + $ - HR4(0, -1,-1,1) + $ - HR4(0,1, -1,-1) + $ - HR4(0,1, -1,1) + HY4(0,-1,-1,1) = + $ + 3.4159126166513913d-02 + $ - 9.4753004230127705d-02*HR1(-1) + $ + 2.9112026323250625d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ - HR1( -1)*HR1(0)*HR2(-1,1) + $ + 5.8224052646501250d-01*HR1(-1)*HR1(1) + $ - HR1( -1)*HR1(1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ - HR1( -1)*HR3(-1,-1,1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + HR1(0) *HR3(-1,-1,1) + $ - 9.4753004230127705d-02*HR1(1) + $ + HR1(1) *HR3(0,-1,-1) + $ - 5.8224052646501250d-01*HR2(-1,1) + $ + HR2( -1,1)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR3(-1,-1,1) + $ + HR4( -1,-1,-1,1) + $ - HR4(0, -1,-1,-1) + $ - HR4(0, -1,-1,1) + HY4(0,-1,1,-1) = + $ + 5.4653052738263652d-02 + $ - 2.1407237086670622d-01*HR1(-1) + $ - 5.3134677019160696d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(0)*HR1(1) + $ - 1.0626935403832139d+00*HR1(-1)*HR1(1) + $ + HR1( -1)*HR1(1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ + 6.9314718055994530d-01*HR1(-1)*HR2(0,-1) + $ - HR1( -1)*HR3(-1,-1,1) + $ - 2.0000000000000000d+00*HR1(-1)*HR3(0,-1,-1) + $ + 6.9314718055994530d-01*HR1(0)*HR2(-1,1) + $ - 2.1407237086670622d-01*HR1(1) + $ + 6.9314718055994530d-01*HR1(1)*HR2(0,-1) + $ - 2.0000000000000000d+00*HR1(1)*HR3(0,-1,-1) + $ + 1.0626935403832139d+00*HR2(-1,1) + $ - HR2( -1,1)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR3(-1,-1,1) + $ - 6.9314718055994530d-01*HR3(0,-1,-1) + $ - 6.9314718055994530d-01*HR3(0,-1,1) + $ + HR4( -1,-1,-1,1) + $ + 3.0000000000000000d+00*HR4(0,-1,-1,-1) + $ + 2.0000000000000000d+00*HR4(0,-1,-1,1) + $ + HR4(0, -1,1,-1) + HY4(0,1,-1,-1) = + $ + 1.1412342741606084d-01 + $ + 4.7533770109129867d-01*HR1(-1) + $ - 1.2011325347955035d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ + 2.4022650695910071d-01*HR1(-1)*HR1(0) + $ - 2.4022650695910071d-01*HR1(-1)*HR1(1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(0,-1) + $ - HR1( -1)*HR3(-1,-1,1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + 2.4022650695910071d-01*HR1(0)*HR1(1) + $ + 4.7533770109129867d-01*HR1(1) + $ - 6.9314718055994530d-01*HR1(1)*HR2(0,-1) + $ + HR1(1) *HR3(0,-1,-1) + $ + 2.4022650695910071d-01*HR2(-1,1) + $ - 2.4022650695910071d-01*HR2(0,-1) + $ - 2.4022650695910071d-01*HR2(0,1) + $ + 6.9314718055994530d-01*HR3(-1,-1,1) + $ + 1.3862943611198906d+00*HR3(0,-1,-1) + $ + 6.9314718055994530d-01*HR3(0,-1,1) + $ + 6.9314718055994530d-01*HR3(0,1,-1) + $ + HR4( -1,-1,-1,1) + $ - 3.0000000000000000d+00*HR4(0,-1,-1,-1) + $ - HR4(0, -1,-1,1) + $ - HR4(0, -1,1,-1) + $ - HR4(0,1, -1,-1) + HY4(0,-1,1,1) = + $ + 9.3097125991768577d-02 + $ - 5.3721319360804020d-01*HR1(-1) + $ + 1.2011325347955035d-01*HR1(-1)*HR1(-1) + $ - 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(0) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(0)*HR1(1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(0)*HR1(1) + $ + HR1( -1)*HR1(0)*HR2(-1,1) + $ - HR1( -1)*HR1(0)*HR2(0,-1) + $ + 2.4022650695910071d-01*HR1(-1)*HR1(1) + $ + 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(0,-1) + $ + HR1( -1)*HR3(-1,-1,1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + HR1( -1)*HR3(0,0,-1) + $ - 5.0000000000000000d-01*HR1(0)*HR1(0)*HR2(-1,1) + $ - HR1(0) *HR1(1)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(0)*HR2(-1,1) + $ - HR1(0) *HR3(-1,-1,1) + $ + HR1(0) *HR3(0,-1,-1) + $ + HR1(0) *HR3(0,-1,1) + $ - 5.3721319360804020d-01*HR1(1) + $ - 6.9314718055994530d-01*HR1(1)*HR2(0,-1) + $ + HR1(1) *HR3(0,-1,-1) + $ + HR1(1) *HR3(0,0,-1) + $ - 2.4022650695910071d-01*HR2(-1,1) + $ - 6.9314718055994530d-01*HR3(-1,-1,1) + $ + 6.9314718055994530d-01*HR3(0,-1,-1) + $ + 6.9314718055994530d-01*HR3(0,-1,1) + $ - HR4( -1,-1,-1,1) + $ - 2.0000000000000000d+00*HR4(0,-1,-1,-1) + $ - HR4(0, -1,-1,1) + $ - HR4(0, -1,1,-1) + $ - HR4(0,0, -1,-1) + $ - HR4(0,0, -1,1) + HY4(0,1,-1,1) = + $ + 1.9355535381306524d-01 + $ + 1.4780047665430420d+00*HR1(-1) + $ - 2.9112026323250625d-01*HR1(-1)*HR1(-1) + $ - 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ + 5.8224052646501250d-01*HR1(-1)*HR1(0) + $ + HR1( -1)*HR1(0)*HR2(-1,1) + $ + HR1( -1)*HR1(0)*HR2(0,-1) + $ - 5.8224052646501250d-01*HR1(-1)*HR1(1) + $ + HR1( -1)*HR1(1)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ + 6.9314718055994530d-01*HR1(-1)*HR2(0,-1) + $ + HR1( -1)*HR3(-1,-1,1) + $ - 2.0000000000000000d+00*HR1(-1)*HR3(0,-1,-1) + $ - 2.0000000000000000d+00*HR1(-1)*HR3(0,0,-1) + $ + 5.8224052646501250d-01*HR1(0)*HR1(1) + $ + HR1(0) *HR1(1)*HR2(0,-1) + $ - HR1(0) *HR3(-1,-1,1) + $ - 2.0000000000000000d+00*HR1(0)*HR3(0,-1,-1) + $ - HR1(0) *HR3(0,-1,1) + $ - HR1(0) *HR3(0,1,-1) + $ + 1.4780047665430420d+00*HR1(1) + $ + 6.9314718055994530d-01*HR1(1)*HR2(0,-1) + $ - 2.0000000000000000d+00*HR1(1)*HR3(0,-1,-1) + $ - 2.0000000000000000d+00*HR1(1)*HR3(0,0,-1) + $ + 5.8224052646501250d-01*HR2(-1,1) + $ - HR2( -1,1)*HR2(0,-1) + $ - 5.8224052646501250d-01*HR2(0,-1) + $ + 5.0000000000000000d-01*HR2(0,-1)*HR2(0,-1) + $ + HR2(0, -1)*HR2(0,1) + $ - 5.8224052646501250d-01*HR2(0,1) + $ - 6.9314718055994530d-01*HR3(-1,-1,1) + $ - 1.3862943611198906d+00*HR3(0,-1,-1) + $ - 6.9314718055994530d-01*HR3(0,-1,1) + $ - 6.9314718055994530d-01*HR3(0,1,-1) + $ - HR4( -1,-1,-1,1) + $ + 4.0000000000000000d+00*HR4(0,-1,-1,-1) + $ + 2.0000000000000000d+00*HR4(0,-1,-1,1) + $ - HR4(0, -1,0,1) + $ + HR4(0, -1,1,-1) + $ + 2.0000000000000000d+00*HR4(0,0,-1,-1) + $ + HR4(0,1, -1,-1) + HY4(0,1,1,-1) = + $ + 4.3369237704895519d-01 + $ - 1.1073038989294665d+00*HR1(-1) + $ + 5.3134677019160696d-01*HR1(-1)*HR1(-1) + $ - 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(0) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(-1,1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ - 1.0626935403832139d+00*HR1(-1)*HR1(0) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(0)*HR1(0) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(0)*HR1(1) + $ + 1.0626935403832139d+00*HR1(-1)*HR1(1) + $ - HR1( -1)*HR1(1)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR1(-1)*HR2(-1,1) + $ + HR1( -1)*HR3(-1,-1,1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + HR1( -1)*HR3(0,0,-1) + $ - 3.4657359027997265d-01*HR1(0)*HR1(0)*HR1(1) + $ - 1.0626935403832139d+00*HR1(0)*HR1(1) + $ - 6.9314718055994530d-01*HR1(0)*HR2(-1,1) + $ + 6.9314718055994530d-01*HR1(0)*HR2(0,-1) + $ + 6.9314718055994530d-01*HR1(0)*HR2(0,1) + $ - 1.1073038989294665d+00*HR1(1) + $ + HR1(1) *HR3(0,-1,-1) + $ + HR1(1) *HR3(0,0,-1) + $ - 1.0626935403832139d+00*HR2(-1,1) + $ + HR2( -1,1)*HR2(0,-1) + $ + 1.0626935403832139d+00*HR2(0,-1) + $ - 5.0000000000000000d-01*HR2(0,-1)*HR2(0,-1) + $ - HR2(0, -1)*HR2(0,1) + $ + 1.0626935403832139d+00*HR2(0,1) + $ - 6.9314718055994530d-01*HR3(-1,-1,1) + $ - 6.9314718055994530d-01*HR3(0,-1,-1) + $ - 6.9314718055994530d-01*HR3(0,0,-1) + $ - 6.9314718055994530d-01*HR3(0,0,1) + $ - 6.9314718055994530d-01*HR3(0,1,-1) + $ - HR4( -1,-1,-1,1) + $ - HR4(0, -1,-1,1) + $ + HR4(0, -1,0,1) + $ + HR4(0,0, -1,1) + $ + HR4(0,0,1, -1) + $ + HR4(0,1, -1,-1) + HY4(-1,-1,-1,1) = + $ + 1.4134237214990008d-02 + $ - 9.4753004230127705d-02*HR1(-1) + $ + 2.9112026323250625d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR2(0,-1) + $ + HR1( -1)*HR3(0,-1,-1) + $ - HR4(0, -1,-1,-1) + HY4(-1,-1,1,1) = + $ + 4.0758239159309251d-02 + $ - 5.3721319360804020d-01*HR1(-1) + $ + 1.2011325347955035d-01*HR1(-1)*HR1(-1) + $ - 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(0) + $ - HR1( -1)*HR1(0)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(-1)*HR2(0,-1) + $ + HR1( -1)*HR3(0,-1,-1) + $ + HR1( -1)*HR3(0,0,-1) + $ + HR1(0) *HR3(0,-1,-1) + $ + 6.9314718055994530d-01*HR3(0,-1,-1) + $ - 2.0000000000000000d+00*HR4(0,-1,-1,-1) + $ - HR4(0,0, -1,-1) + HY4(-1,1,1,1) = + $ + 5.1747906167389938d-01 + $ + 5.5504108664821579d-02*HR1(-1) + $ - 1.2011325347955035d-01*HR1(-1)*HR1(-1) + $ + 1.1552453009332421d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 4.1666666666666666d-02*HR1(-1)*HR1(-1)*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1)*HR1(0) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1)*HR1(0) + $ - 2.5000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0)*HR1(0) + $ + 2.4022650695910071d-01*HR1(-1)*HR1(0) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(0)*HR1(0) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(0)*HR1(0)*HR1(0) + $ - 5.0000000000000000d-01*HR1(0)*HR1(0)*HR2(0,-1) + $ - 6.9314718055994530d-01*HR1(0)*HR2(0,-1) + $ + HR1(0) *HR3(0,-1,-1) + $ + HR1(0) *HR3(0,0,-1) + $ - 2.4022650695910071d-01*HR2(0,-1) + $ + 6.9314718055994530d-01*HR3(0,-1,-1) + $ + 6.9314718055994530d-01*HR3(0,0,-1) + $ - HR4(0, -1,-1,-1) + $ - HR4(0,0, -1,-1) + $ - HR4(0,0,0, -1) + if (r.lt.0d0) then + HY4(0,-1,1,1) = HY4(0,-1,1,1) + $ - 2.4674011002723396d+00*HR1(-1)*HR1(-1) + $ - 4.9348022005446793d+00*HR1(-1)*HR1(1) + $ + 4.9348022005446793d+00*HR2(-1,1) + HY4(0,1,1,-1) = HY4(0,1,1,-1) + $ + 3.4205442319285582d+00*HR1(-1) + $ + 3.4205442319285582d+00*HR1(1) + HY4(-1,-1,1,1) = HY4(-1,-1,1,1) + $ - 2.4674011002723396d+00*HR1(-1)*HR1(-1) + HY4(-1,1,1,1) = HY4(-1,1,1,1) + $ - 3.4205442319285582d+00*HR1(-1) + $ + 2.4674011002723396d+00*HR1(-1)*HR1(-1) + $ - 4.9348022005446793d+00*HR1(-1)*HR1(0) + $ + 4.9348022005446793d+00*HR2(0,-1) + Hi4(0,0,-1,1) = + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(1)*HR1(1) + $ + HR1(1) *HR2(-1,1) + $ + HR3( -1,-1,1) + $ - HR3( -1,1,1) + Hi4(0,0,1,-1) = + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ + 3.4657359027997265d-01*HR1(1)*HR1(1) + Hi4(0,-1,0,1) = + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + HR1( -1)*HR2(-1,1) + $ - HR1(1) *HR2(-1,1) + $ - 2.0000000000000000d+00*HR3(-1,-1,1) + $ + 2.0000000000000000d+00*HR3(-1,1,1) + Hi4(0,-1,-1,1) = + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ + HR1( -1)*HR2(-1,1) + $ - HR3( -1,-1,1) + Hi4(0,-1,1,-1) = + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ - 6.9314718055994530d-01*HR2(-1,1) + Hi4(0,1,-1,-1) = + $ - 2.4022650695910071d-01*HR1(-1) + $ - 2.4022650695910071d-01*HR1(1) + Hi4(0,-1,1,1) = + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - HR1( -1)*HR1(0)*HR1(1) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ - HR1( -1)*HR2(-1,1) + $ + HR1( -1)*HR2(0,-1) + $ + HR1(0) *HR2(-1,1) + $ + HR1(1) *HR2(0,-1) + $ + 6.9314718055994530d-01*HR2(-1,1) + $ + HR3( -1,-1,1) + $ - HR3(0, -1,-1) + $ - HR3(0, -1,1) + Hi4(0,1,-1,1) = + $ - 5.8224052646501250d-01*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(1) + $ - HR1( -1)*HR2(-1,1) + $ - HR1( -1)*HR2(0,-1) + $ - 5.8224052646501250d-01*HR1(1) + $ - HR1(1) *HR2(0,-1) + $ + HR3( -1,-1,1) + $ + 2.0000000000000000d+00*HR3(0,-1,-1) + $ + HR3(0, -1,1) + $ + HR3(0,1, -1) + Hi4(0,1,1,-1) = + $ + 1.0626935403832139d+00*HR1(-1) + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 6.9314718055994530d-01*HR1(-1)*HR1(0) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(1) + $ + 6.9314718055994530d-01*HR1(0)*HR1(1) + $ + 1.0626935403832139d+00*HR1(1) + $ + 6.9314718055994530d-01*HR2(-1,1) + $ - 6.9314718055994530d-01*HR2(0,-1) + $ - 6.9314718055994530d-01*HR2(0,1) + Hi4(-1,-1,-1,1) = + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + Hi4(-1,-1,1,1) = + $ - 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ + 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ + HR1( -1)*HR2(0,-1) + $ - HR3(0, -1,-1) + Hi4(-1,1,1,1) = + $ + 1.4047075598891257d+00*HR1(-1) + $ + 3.4657359027997265d-01*HR1(-1)*HR1(-1) + $ - 1.6666666666666666d-01*HR1(-1)*HR1(-1)*HR1(-1) + $ + 5.0000000000000000d-01*HR1(-1)*HR1(-1)*HR1(0) + $ - 6.9314718055994530d-01*HR1(-1)*HR1(0) + $ - 5.0000000000000000d-01*HR1(-1)*HR1(0)*HR1(0) + $ + HR1(0) *HR2(0,-1) + $ + 6.9314718055994530d-01*HR2(0,-1) + $ - HR3(0, -1,-1) + $ - HR3(0,0, -1) + endif + endif +** nw > 3 endif + endif +** (n1,n2) = (-1,1) -- completion endif + return + end +************************************************************************ + subroutine fillirr1dhplatinf(x,nw,HX1,HX2,HX3,HX4, + $ HY1,HY2,HY3,HY4, + $ Hi1,Hi2,Hi3,Hi4,n1,n2) +** evaluates the HPL for y > r2p1 +** fillirr1dhplatinf is called by eval1dhplatinf after calling +** fillirr1dhplat0 with argument r=1/y +** it is guaranteed that nw is in the range 2:4, and that (n1,n2) +** take one of the pairs of values (0,1), (-1,0) or (-1,1) + implicit double precision (a-h,o-z) + dimension HX1(n1:n2),HX2(n1:n2,n1:n2),HX3(n1:n2,n1:n2,n1:n2), + $ HX4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) + dimension Hi1(n1:n2),Hi2(n1:n2,n1:n2),Hi3(n1:n2,n1:n2,n1:n2), + $ Hi4(n1:n2,n1:n2,n1:n2,n1:n2) +** (n1,n2) = (0,1) or (-1,1) + if ( ( (n1.eq.0).and.(n2.eq.1) ) + $ .or.( (n1.eq.-1).and.(n2.eq.1) ) ) then + HY2(0,1) = + $ + 3.2898681336964528d+00 + $ - 5.0000000000000000d-01*HX1(0)*HX1(0) + $ - HX2(0,1) + Hi2(0,1) = + $ - HX1(0) + if ( nw.gt.2 ) then + HY3(0,0,1) = + $ - 3.2898681336964528d+00*HX1(0) + $ + 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX3(0,0,1) + HY3(0,1,1) = + $ + 1.2020569031595942d+00 + $ + 4.9348022005446793d+00*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ - HX1(0) *HX2(0,1) + $ + HX3(0,0,1) + $ - HX3(0,1,1) + Hi3(0,0,1) = + $ + 5.000000000000000d-01*HX1(0)*HX1(0) + Hi3(0,1,1) = + $ + 1.6449340668482264d+00 + $ - 5.0000000000000000d-01*HX1(0)*HX1(0) + $ - HX2(0,1) + endif + if ( nw.gt.3 ) then + HY4(0,0,0,1) = + $ + 2.1646464674222763d+00 + $ + 1.6449340668482264d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ - HX4(0,0,0,1) + HY4(0,0,1,1) = + $ + 2.1646464674222763d+00 + $ - 1.2020569031595942d+00*HX1(0) + $ - 2.4674011002723396d+00*HX1(0)*HX1(0) + $ + 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX3(0,0,1) + $ - 2.0000000000000000d+00*HX4(0,0,0,1) + $ + HX4(0,0,1,1) + HY4(0,1,1,1) = + $ - 5.1410353601279064d+00 + $ + 2.4674011002723396d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ - 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,1) + $ + HX1(0) *HX3(0,0,1) + $ - HX1(0) *HX3(0,1,1) + $ + 4.9348022005446793d+00*HX2(0,1) + $ - HX4(0,0,0,1) + $ + HX4(0,0,1,1) + $ - HX4(0,1,1,1) + Hi4(0,0,0,1) = + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + Hi4(0,0,1,1) = + $ - 1.2020569031595942d+00 + $ - 1.6449340668482264d+00*HX1(0) + $ + 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX3(0,0,1) + Hi4(0,1,1,1) = + $ + 1.6449340668482264d+00*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ - HX1(0) *HX2(0,1) + $ + HX3(0,0,1) + $ - HX3(0,1,1) + endif +** nw > 3 endif + endif +** (n1,n2) = (0,1) or (-1,1) endif +************ +** (n1,n2) = (-1,0) or (-1,1) + if ( ( (n1.eq.-1).and.(n2.eq.0) ) + $ .or.( (n1.eq.-1).and.(n2.eq.1) ) ) then + HY2(0,-1) = + $ + 1.6449340668482264d+00 + $ + 5.0000000000000000d-01*HX1(0)*HX1(0) + $ - HX2(0, -1) + if ( nw.gt.2 ) then + HY3(0,0,-1) = + $ - 1.6449340668482264d+00*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX3(0,0, -1) + HY3(0,-1,-1) = + $ + 1.2020569031595942d+00 + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX2(0,-1) + $ - HX3(0, -1,-1) + $ - HX3(0,0, -1) + endif + if ( nw.gt.3 ) then + HY4(0,0,0,-1) = + $ + 1.8940656589944918d+00 + $ + 8.2246703342411321d-01*HX1(0)*HX1(0) + $ + 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ - HX4(0,0,0, -1) + HY4(0,0,-1,-1) = + $ - 1.8940656589944918d+00 + $ - 1.2020569031595942d+00*HX1(0) + $ + 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ - HX1(0) *HX3(0,0,-1) + $ + HX4(0,0, -1,-1) + $ + 2.0000000000000000d+00*HX4(0,0,0,-1) + HY4(0,-1,-1,-1) = + $ + 1.0823232337111381d+00 + $ + 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ - 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,-1) + $ + HX1(0) *HX3(0,-1,-1) + $ + HX1(0) *HX3(0,0,-1) + $ - HX4(0, -1,-1,-1) + $ - HX4(0,0, -1,-1) + $ - HX4(0,0,0, -1) + endif +** nw > 3 endif + endif +** (n1,n2) = (-1,0) or (-1,1) endif +** (n1,n2) = (-1,1) -- completion + if ( (n1.eq.-1).and.(n2.eq.1) ) then + HY2(-1,1) = + $ + 2.4674011002723396d+00 + $ + HX1( -1)*HX1(0) + $ - 5.0000000000000000d-01*HX1(0)*HX1(0) + $ + HX2( -1,1) + $ - HX2(0, -1) + $ - HX2(0,1) + Hi2(-1,1) = + $ - 6.9314718055994530d-01 + $ + HX1( -1) + $ - HX1(0) + if ( nw.gt.2 ) then + HY3(0,-1,1) = + $ - 2.5190015545588625d+00 + $ - 2.4674011002723396d+00*HX1(0) + $ + 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ - HX1(0) *HX2(0,-1) + $ - HX3(0, -1,1) + $ + 2.0000000000000000d+00*HX3(0,0,-1) + $ + HX3(0,0,1) + HY3(0,1,-1) = + $ + 4.3220869092982539d+00 + $ + 2.4674011002723396d+00*HX1(0) + $ + 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX2(0,1) + $ - HX3(0,0, -1) + $ - 2.0000000000000000d+00*HX3(0,0,1) + $ - HX3(0,1, -1) + HY3(-1,-1,1) = + $ - 2.7620719062289241d+00 + $ + 2.4674011002723396d+00*HX1(-1) + $ + 5.0000000000000000d-01*HX1(-1)*HX1(-1)*HX1(0) + $ - 5.0000000000000000d-01*HX1(-1)*HX1(0)*HX1(0) + $ - HX1( -1)*HX2(0,-1) + $ - HX1( -1)*HX2(0,1) + $ - 2.4674011002723396d+00*HX1(0) + $ + 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX3( -1,-1,1) + $ + HX3(0, -1,-1) + $ + HX3(0,0, -1) + $ + HX3(0,0,1) + $ + HX3(0,1, -1) + HY3(-1,1,1) = + $ + 2.7620719062289241d+00 + $ - 4.9348022005446793d+00*HX1(-1) + $ + 5.0000000000000000d-01*HX1(-1)*HX1(0)*HX1(0) + $ + 4.9348022005446793d+00*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX2(-1,1) + $ - HX1(0) *HX2(0,-1) + $ - HX1(0) *HX2(0,1) + $ + HX3( -1,1,1) + $ - HX3(0, -1,1) + $ + HX3(0,0, -1) + $ + HX3(0,0,1) + $ - HX3(0,1,1) + Hi3(0,-1,1) = + $ + 8.2246703342411321d-01 + $ + 6.9314718055994530d-01*HX1(0) + $ + 5.0000000000000000d-01*HX1(0)*HX1(0) + $ - HX2(0, -1) + Hi3(0,1,-1) = + $ - 6.9314718055994530d-01*HX1(0) + Hi3(-1,-1,1) = + $ + 2.4022650695910071d-01 + $ - 6.9314718055994530d-01*HX1(-1) + $ + 5.0000000000000000d-01*HX1(-1)*HX1(-1) + $ - HX1( -1)*HX1(0) + $ + 6.9314718055994530d-01*HX1(0) + $ + 5.0000000000000000d-01*HX1(0)*HX1(0) + Hi3(-1,1,1) = + $ + 1.8851605738073271d+00 + $ + HX1( -1)*HX1(0) + $ - 5.0000000000000000d-01*HX1(0)*HX1(0) + $ + HX2( -1,1) + $ - HX2(0, -1) + $ - HX2(0,1) + endif + if ( nw.gt.3 ) then + HY4(0,0,-1,1) = + $ + 3.9234217222028759d+00 + $ + 2.5190015545588625d+00*HX1(0) + $ + 1.2337005501361698d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX3(0,0,-1) + $ + HX4(0,0, -1,1) + $ - 3.0000000000000000d+00*HX4(0,0,0,-1) + $ - HX4(0,0,0,1) + HY4(0,0,1,-1) = + $ - 4.1940025306306604d+00 + $ - 4.3220869092982539d+00*HX1(0) + $ - 1.2337005501361698d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ - HX1(0) *HX3(0,0,1) + $ + HX4(0,0,0, -1) + $ + 3.0000000000000000d+00*HX4(0,0,0,1) + $ + HX4(0,0,1, -1) + HY4(0,-1,0,1) = + $ + 9.4703282949724591d-01 + $ + 1.8030853547393914d+00*HX1(0) + $ + 1.6449340668482264d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,-1) + $ - 2.0000000000000000d+00*HX1(0)*HX3(0,0,-1) + $ - 3.2898681336964528d+00*HX2(0,-1) + $ + HX4(0, -1,0,1) + $ + 3.0000000000000000d+00*HX4(0,0,0,-1) + $ - HX4(0,0,0,1) + HY4(0,-1,-1,1) = + $ + 2.5209599327464717d+00 + $ + 2.7620719062289241d+00*HX1(0) + $ + 1.2337005501361698d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,-1) + $ - HX1(0) *HX3(0,-1,-1) + $ - HX1(0) *HX3(0,0,-1) + $ - 2.4674011002723396d+00*HX2(0,-1) + $ + 5.0000000000000000d-01*HX2(0,-1)*HX2(0,-1) + $ - HX4(0, -1,-1,1) + $ + HX4(0, -1,0,1) + $ + HX4(0,0, -1,1) + $ - HX4(0,0,0,1) + HY4(0,-1,1,-1) = + $ - 8.5266539820739622d+00 + $ - 5.5241438124578482d+00*HX1(0) + $ - 1.2337005501361698d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,-1) + $ + HX1(0) *HX3(0,-1,1) + $ - 2.0000000000000000d+00*HX1(0)*HX3(0,0,-1) + $ - HX1(0) *HX3(0,0,1) + $ + 2.4674011002723396d+00*HX2(0,-1) + $ - 5.0000000000000000d-01*HX2(0,-1)*HX2(0,-1) + $ - HX4(0, -1,0,1) + $ - HX4(0, -1,1,-1) + $ + 2.0000000000000000d+00*HX4(0,0,-1,-1) + $ - 2.0000000000000000d+00*HX4(0,0,-1,1) + $ + 4.0000000000000000d+00*HX4(0,0,0,-1) + $ + 3.0000000000000000d+00*HX4(0,0,0,1) + $ + HX4(0,0,1, -1) + HY4(0,1,-1,-1) = + $ + 5.8027584430066521d+00 + $ + 2.7620719062289241d+00*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ - 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,1) + $ + HX1(0) *HX3(0,0,-1) + $ + 2.0000000000000000d+00*HX1(0)*HX3(0,0,1) + $ + HX1(0) *HX3(0,1,-1) + $ - HX4(0,0, -1,-1) + $ - 2.0000000000000000d+00*HX4(0,0,0,-1) + $ - 3.0000000000000000d+00*HX4(0,0,0,1) + $ - 2.0000000000000000d+00*HX4(0,0,1,-1) + $ - HX4(0,1, -1,-1) + HY4(0,-1,1,1) = + $ + 6.2689427375197987d-01 + $ - 2.7620719062289241d+00*HX1(0) + $ - 2.4674011002723396d+00*HX1(0)*HX1(0) + $ + 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ - 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,-1) + $ - HX1(0) *HX3(0,-1,1) + $ + 2.0000000000000000d+00*HX1(0)*HX3(0,0,-1) + $ + HX1(0) *HX3(0,0,1) + $ + 4.9348022005446793d+00*HX2(0,-1) + $ - HX4(0, -1,1,1) + $ + 2.0000000000000000d+00*HX4(0,0,-1,1) + $ - 3.0000000000000000d+00*HX4(0,0,0,-1) + $ - 2.0000000000000000d+00*HX4(0,0,0,1) + $ + HX4(0,0,1,1) + HY4(0,1,-1,1) = + $ - 4.3326514514433017d+00 + $ - 1.3169446513992682d+00*HX1(0) + $ - 1.2337005501361698d+00*HX1(0)*HX1(0) + $ + 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,1) + $ - HX1(0) *HX3(0,0,-1) + $ - 2.0000000000000000d+00*HX1(0)*HX3(0,0,1) + $ - HX1(0) *HX3(0,1,-1) + $ + HX2(0, -1)*HX2(0,1) + $ - 2.4674011002723396d+00*HX2(0,1) + $ + 5.0000000000000000d-01*HX2(0,1)*HX2(0,1) + $ - HX4(0, -1,0,1) + $ - 3.0000000000000000d+00*HX4(0,0,-1,1) + $ + 3.0000000000000000d+00*HX4(0,0,0,-1) + $ + 4.0000000000000000d+00*HX4(0,0,0,1) + $ - 2.0000000000000000d+00*HX4(0,0,1,1) + $ - HX4(0,1, -1,1) + HY4(0,1,1,-1) = + $ - 1.5001934240460787d-01 + $ + 4.0790165576281924d+00*HX1(0) + $ + 1.2337005501361698d+00*HX1(0)*HX1(0) + $ + 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,1) + $ - HX1(0) *HX3(0,0,1) + $ + HX1(0) *HX3(0,1,1) + $ - HX2(0, -1)*HX2(0,1) + $ + 2.4674011002723396d+00*HX2(0,1) + $ - 5.0000000000000000d-01*HX2(0,1)*HX2(0,1) + $ + HX4(0, -1,0,1) + $ + 2.0000000000000000d+00*HX4(0,0,-1,1) + $ - HX4(0,0,0, -1) + $ + HX4(0,0,1, -1) + $ - HX4(0,1,1, -1) + HY4(-1,-1,-1,1) = + $ + 2.4278628067547031d+00 + $ - 2.7620719062289241d+00*HX1(-1) + $ + 1.2337005501361698d+00*HX1(-1)*HX1(-1) + $ + 1.6666666666666666d-01*HX1(-1)*HX1(-1)*HX1(-1)*HX1(0) + $ - 2.5000000000000000d-01*HX1(-1)*HX1(-1)*HX1(0)*HX1(0) + $ - 5.0000000000000000d-01*HX1(-1)*HX1(-1)*HX2(0,-1) + $ - 5.0000000000000000d-01*HX1(-1)*HX1(-1)*HX2(0,1) + $ - 2.4674011002723396d+00*HX1(-1)*HX1(0) + $ + 1.6666666666666666d-01*HX1(-1)*HX1(0)*HX1(0)*HX1(0) + $ + HX1( -1)*HX3(0,-1,-1) + $ + HX1( -1)*HX3(0,0,-1) + $ + HX1( -1)*HX3(0,0,1) + $ + HX1( -1)*HX3(0,1,-1) + $ + 2.7620719062289241d+00*HX1(0) + $ + 1.2337005501361698d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + HX4( -1,-1,-1,1) + $ - HX4(0, -1,-1,-1) + $ - HX4(0,0, -1,-1) + $ - HX4(0,0,0, -1) + $ - HX4(0,0,0,1) + $ - HX4(0,0,1, -1) + $ - HX4(0,1, -1,-1) + HY4(-1,-1,1,1) = + $ + 2.0293560632083841d+00 + $ + 2.7620719062289241d+00*HX1(-1) + $ - 2.4674011002723396d+00*HX1(-1)*HX1(-1) + $ + 2.5000000000000000d-01*HX1(-1)*HX1(-1)*HX1(0)*HX1(0) + $ + 4.9348022005446793d+00*HX1(-1)*HX1(0) + $ - 1.6666666666666666d-01*HX1(-1)*HX1(0)*HX1(0)*HX1(0) + $ - HX1( -1)*HX1(0)*HX2(0,-1) + $ - HX1( -1)*HX1(0)*HX2(0,1) + $ - HX1( -1)*HX3(0,-1,1) + $ + HX1( -1)*HX3(0,0,-1) + $ + HX1( -1)*HX3(0,0,1) + $ - HX1( -1)*HX3(0,1,1) + $ - 2.7620719062289241d+00*HX1(0) + $ - 2.4674011002723396d+00*HX1(0)*HX1(0) + $ + 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX3(-1,-1,1) + $ + HX1(0) *HX3(0,-1,-1) + $ + HX1(0) *HX3(0,0,-1) + $ + HX1(0) *HX3(0,0,1) + $ + HX1(0) *HX3(0,1,-1) + $ + HX4( -1,-1,1,1) + $ + HX4(0, -1,-1,1) + $ + HX4(0, -1,1,-1) + $ - HX4(0,0, -1,-1) + $ + HX4(0,0, -1,1) + $ - 2.0000000000000000d+00*HX4(0,0,0,-1) + $ - 2.0000000000000000d+00*HX4(0,0,0,1) + $ - HX4(0,0,1, -1) + $ + HX4(0,0,1,1) + $ + HX4(0,1, -1,1) + $ + HX4(0,1,1, -1) + HY4(-1,1,1,1) = + $ - 6.4865749331714713d+00 + $ - 4.9348022005446793d+00*HX1(-1)*HX1(0) + $ + 1.6666666666666666d-01*HX1(-1)*HX1(0)*HX1(0)*HX1(0) + $ + 2.4674011002723396d+00*HX1(0)*HX1(0) + $ - 4.1666666666666666d-02*HX1(0)*HX1(0)*HX1(0)*HX1(0) + $ + 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(-1,1) + $ - 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,-1) + $ - 5.0000000000000000d-01*HX1(0)*HX1(0)*HX2(0,1) + $ + HX1(0) *HX3(-1,1,1) + $ - HX1(0) *HX3(0,-1,1) + $ + HX1(0) *HX3(0,0,-1) + $ + HX1(0) *HX3(0,0,1) + $ - HX1(0) *HX3(0,1,1) + $ - 4.9348022005446793d+00*HX2(-1,1) + $ + 4.9348022005446793d+00*HX2(0,-1) + $ + 4.9348022005446793d+00*HX2(0,1) + $ + HX4( -1,1,1,1) + $ - HX4(0, -1,1,1) + $ + HX4(0,0, -1,1) + $ - HX4(0,0,0, -1) + $ - HX4(0,0,0,1) + $ + HX4(0,0,1,1) + $ - HX4(0,1,1,1) + Hi4(0,0,-1,1) = + $ - 9.0154267736969571d-01 + $ - 8.2246703342411321d-01*HX1(0) + $ - 3.4657359027997265d-01*HX1(0)*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX3(0,0, -1) + Hi4(0,0,1,-1) = + $ + 3.4657359027997265d-01*HX1(0)*HX1(0) + Hi4(0,-1,0,1) = + $ + 1.8030853547393914d+00 + $ + 8.2246703342411321d-01*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX2(0,-1) + $ - 2.0000000000000000d+00*HX3(0,0,-1) + Hi4(0,-1,-1,1) = + $ + 4.8170908494321862d-01 + $ - 2.4022650695910071d-01*HX1(0) + $ - 3.4657359027997265d-01*HX1(0)*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX2(0,-1) + $ + 6.9314718055994530d-01*HX2(0,-1) + $ - HX3(0, -1,-1) + $ - HX3(0,0, -1) + Hi4(0,-1,1,-1) = + $ + 5.7009070532142637d-01 + $ + 4.8045301391820142d-01*HX1(0) + $ + 3.4657359027997265d-01*HX1(0)*HX1(0) + $ - 6.9314718055994530d-01*HX2(0,-1) + Hi4(0,1,-1,-1) = + $ - 2.4022650695910071d-01*HX1(0) + Hi4(0,-1,1,1) = + $ - 2.7620719062289241d+00 + $ - 1.8851605738073271d+00*HX1(0) + $ + 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ - HX1(0) *HX2(0,-1) + $ - HX3(0, -1,1) + $ + 2.0000000000000000d+00*HX3(0,0,-1) + $ + HX3(0,0,1) + Hi4(0,1,-1,1) = + $ + 2.6736902858507163d+00 + $ + 1.3029200473423146d+00*HX1(0) + $ + 3.4657359027997265d-01*HX1(0)*HX1(0) + $ + 1.6666666666666665d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX2(0,1) + $ + 6.9314718055994530d-01*HX2(0,1) + $ - HX3(0,0, -1) + $ - 2.0000000000000000d+00*HX3(0,0,1) + $ - HX3(0,1, -1) + Hi4(0,1,1,-1) = + $ + 1.1401814106428527d+00 + $ + 5.8224052646501250d-01*HX1(0) + $ - 3.4657359027997265d-01*HX1(0)*HX1(0) + $ - 6.9314718055994530d-01*HX2(0,1) + Hi4(-1,-1,-1,1) = + $ - 5.5504108664821579d-02 + $ + 2.4022650695910071d-01*HX1(-1) + $ - 3.4657359027997265d-01*HX1(-1)*HX1(-1) + $ + 1.6666666666666666d-01*HX1(-1)*HX1(-1)*HX1(-1) + $ - 5.0000000000000000d-01*HX1(-1)*HX1(-1)*HX1(0) + $ + 6.9314718055994530d-01*HX1(-1)*HX1(0) + $ + 5.0000000000000000d-01*HX1(-1)*HX1(0)*HX1(0) + $ - 2.4022650695910071d-01*HX1(0) + $ - 3.4657359027997265d-01*HX1(0)*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + Hi4(-1,-1,1,1) = + $ - 2.4532465311320902d+00 + $ + 1.8851605738073271d+00*HX1(-1) + $ + 5.0000000000000000d-01*HX1(-1)*HX1(-1)*HX1(0) + $ - 5.0000000000000000d-01*HX1(-1)*HX1(0)*HX1(0) + $ - HX1( -1)*HX2(0,-1) + $ - HX1( -1)*HX2(0,1) + $ - 1.8851605738073271d+00*HX1(0) + $ + 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX3( -1,-1,1) + $ + HX3(0, -1,-1) + $ + HX3(0,0, -1) + $ + HX3(0,0,1) + $ + HX3(0,1, -1) + Hi4(-1,1,1,1) = + $ - 5.5504108664821579d-02 + $ - 1.6449340668482264d+00*HX1(-1) + $ + 5.0000000000000000d-01*HX1(-1)*HX1(0)*HX1(0) + $ + 1.6449340668482264d+00*HX1(0) + $ - 1.6666666666666666d-01*HX1(0)*HX1(0)*HX1(0) + $ + HX1(0) *HX2(-1,1) + $ - HX1(0) *HX2(0,-1) + $ - HX1(0) *HX2(0,1) + $ + HX3( -1,1,1) + $ - HX3(0, -1,1) + $ + HX3(0,0, -1) + $ + HX3(0,0,1) + $ - HX3(0,1,1) + endif +** nw > 3 endif + endif +** (n1,n2) = (-1,1) -- completion endif + return + end +************************************************************************ + subroutine fillirr1dhplin1(y,nw,HY1,HY2,HY3,HY4,n1,n2) +** evaluates the irreducible HPL for y =1 +** it is guaranteed that nw is in the range 2:4, and that (n1,n2) +** take one of the pairs of values (0,1), (-1,0) or (-1,1) + implicit double precision (a-h,o-z) + dimension HY1(n1:n2),HY2(n1:n2,n1:n2),HY3(n1:n2,n1:n2,n1:n2), + $ HY4(n1:n2,n1:n2,n1:n2,n1:n2) +** (n1,n2) = (0,1) or (-1,1) + if ( ( (n1.eq.0).and.(n2.eq.1) ) + $ .or.( (n1.eq.-1).and.(n2.eq.1) ) ) then + HY2(0,1) = + $ + 1.6449340668482264d+00 + if (nw.gt.2) then + HY3(0,0,1) = + $ + 1.2020569031595942d+00 + HY3(0,1,1) = + $ + 1.2020569031595942d+00 + endif + if (nw.gt.3) then + HY4(0,0,0,1) = + $ + 1.0823232337111381d+00 + HY4(0,0,1,1) = + $ + 2.7058080842778454d-01 + HY4(0,1,1,1) = + $ + 1.0823232337111381d+00 + endif + endif +** (n1,n2) = (0,1) or (-1,1) endif +************ +** (n1,n2) = (-1,0) or (-1,1) + if ( ( (n1.eq.-1).and.(n2.eq.0) ) + $ .or.( (n1.eq.-1).and.(n2.eq.1) ) ) then + HY2(0,-1) = + $ + 8.2246703342411321d-01 + if (nw.gt.2) then + HY3(0,-1,-1) = + $ + 1.5025711289494928d-01 + HY3(0,0,-1) = + $ + 9.0154267736969571d-01 + endif + if (nw.gt.3) then + HY4(0,-1,-1,-1) = + $ + 2.3752366322618485d-02 + HY4(0,0,-1,-1) = + $ + 8.7785671568655302d-02 + HY4(0,0,0,-1) = + $ + 9.4703282949724591d-01 + endif + endif +** (n1,n2) = (-1,0) or (-1,1) endif +** (n1,n2) = (-1,1) -- completion + if ( (n1.eq.-1).and.(n2.eq.1) ) then + HY2(-1,1) = + $ + 5.8224052646501250d-01 + if (nw.gt.2) then + HY3(0,-1,1) = + $ + 2.4307035167006157d-01 + HY3(0,1,-1) = + $ + 5.0821521280468485d-01 + HY3(-1,-1,1) = + $ + 9.4753004230127705d-02 + HY3(-1,1,1) = + $ + 5.3721319360804020d-01 + endif + if (nw.gt.3) then + HY4(0,0,-1,1) = + $ + 1.1787599965050932d-01 + HY4(0,0,1,-1) = + $ + 1.7284527823898438d-01 + HY4(0,-1,0,1) = + $ + 2.0293560632083841d-01 + HY4(0,-1,-1,1) = + $ + 3.4159126166513913d-02 + HY4(0,-1,1,-1) = + $ + 5.4653052738263652d-02 + HY4(0,1,-1,-1) = + $ + 1.1412342741606084d-01 + HY4(0,-1,1,1) = + $ + 9.3097125991768577d-02 + HY4(0,1,-1,1) = + $ + 1.9355535381306524d-01 + HY4(0,1,1,-1) = + $ + 4.3369237704895519d-01 + HY4(-1,-1,-1,1) = + $ + 1.4134237214990008d-02 + HY4(-1,-1,1,1) = + $ + 4.0758239159309251d-02 + HY4(-1,1,1,1) = + $ + 5.1747906167389938d-01 + endif + endif +** (n1,n2) = (-1,1) -- completion endif + return + end diff --git a/src/integrator.f90 b/src/integrator.f90 new file mode 100644 index 0000000..d9157d7 --- /dev/null +++ b/src/integrator.f90 @@ -0,0 +1,259 @@ +!====================================================================== +! Need a (set of?) special integrator(s) for going from +! splitting/coefficient functions to splitting/coefficient arrays +! $Id: integrator.f90,v 1.2 2001/07/17 13:51:01 gsalam Exp $ +module integrator + use types; use consts_dp + implicit none + private + + public :: ig_LinWeight, ig_LinWeightSing, ig_PolyWeight +contains + + !====================================================================== + ! Function which integrates F weighted with the linear function which has + ! values AMult and BMult at A & B respectively. + ! + ! Result evaluated roughly with precision EPS (rel or abs + ! whichever is largest). + ! + ! Perhaps in general one is better off writing a version of this routine + ! which has two function, which get multiplied. Then this routine + ! would just set parameters for one of those functions. This would + ! allow the easy generalisation to the case with more complex weight + ! functions. + ! + Recursive FUNCTION ig_LinWeight(F,A,B,AMult,BMult,EPS) result(cgauss64) + real(dp), intent(in) :: A,B,AMult,BMult,EPS + REAL(dp) :: AA,BB,U,C1,C2,S8,S16,H, CGAUSS64, pmult,mmult,Const + real(dp), parameter :: z1 = 1, hf = half*z1, cst = 5*Z1/1000 + real(dp) :: X(12), W(12) + interface + function f(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: f + end function f + end interface + integer :: i + CHARACTER(len=*), parameter :: NAME = 'cgauss64' + + DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ + DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ + DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ + DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ + DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ + DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ + DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ + DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ + DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ + DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ + DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ + DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ + + H=0 + IF(B .EQ. A) GO TO 99 + CONST=CST/ABS(B-A) + BB=A +1 AA=BB + BB=B +2 C1=HF*(BB+AA) + C2=HF*(BB-AA) + S8=0 + DO 3 I = 1,4 + U=C2*X(I) + pmult = ((c1+u) - A)/(B-A) * (BMult -AMult) + AMult + mmult = ((c1-u) - A)/(B-A) * (BMult -AMult) + AMult +3 S8=S8+W(I)*(F(C1+U)*pmult+F(C1-U)*mmult) + S16=0 + DO 4 I = 5,12 + U=C2*X(I) + pmult = ((c1+u) - A)/(B-A) * (BMult -AMult) + AMult + mmult = ((c1-u) - A)/(B-A) * (BMult -AMult) + AMult +4 S16=S16+W(I)*(F(C1+U)*pmult+F(C1-U)*mmult) + S16=C2*S16 + IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN + H=H+S16 + IF(BB .NE. B) GO TO 1 + ELSE + BB=C1 + IF(1+CONST*ABS(C2) .NE. 1) GO TO 2 + H=0 + !CALL MTLPRT(NAME,'D113.1','TOO HIGH ACCURACY REQUIRED') + write(0,*) NAME,'D113.1','TOO HIGH ACCURACY REQUIRED' + GO TO 99 + END IF +99 cgauss64=H + end function ig_LinWeight + + + !------------------------------------------------------- + ! Try to improve convergence on nasty integrals + Recursive FUNCTION ig_LinWeightSing(F,A_in,B_in,AMult,BMult,EPS) & + &result(cgauss64) + real(dp), intent(in) :: A_in,B_in,AMult,BMult,EPS + REAL(dp) :: AA,BB,U,C1,C2,S8,S16,H, CGAUSS64, pmult,mmult,Const + real(dp), parameter :: z1 = 1, hf = half*z1, cst = 5*Z1/1000 + real(dp) :: X(12), W(12), A, B, xp, xm, wp, wm + interface + function f(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: f + end function f + end interface + integer :: i + CHARACTER(len=*), parameter :: NAME = 'cgauss64' + + DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ + DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ + DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ + DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ + DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ + DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ + DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ + DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ + DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ + DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ + DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ + DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ + + + ! change variables specifically for case of singularity close to zero + A = sqrt(A_in); B = sqrt(B_in) + + + H=0 + IF(B .EQ. A) GO TO 99 + CONST=CST/ABS(B-A) + BB=A +1 AA=BB + BB=B +2 C1=HF*(BB+AA) + C2=HF*(BB-AA) + S8=0 + DO 3 I = 1,4 + U=C2*X(I) + !-- get original variables... + xp = (c1+u)**2; xm = (c1-u)**2 + pmult = (xp - A_in)/(B_in-A_in) * (BMult -AMult) + AMult + mmult = (xm - A)/(B-A) * (BMult -AMult) + AMult + !-- account for change of weight due two change of var + pmult = pmult * two*(c1+u) + mmult = mmult * two*(c1-u) +3 S8=S8+W(I)*(F(xp)*pmult+F(xm)*mmult) + S16=0 + DO 4 I = 5,12 + U=C2*X(I) + !-- get original variables... + xp = (c1+u)**2; xm = (c1-u)**2 + pmult = (xp - A_in)/(B_in-A_in) * (BMult -AMult) + AMult + mmult = (xm - A)/(B-A) * (BMult -AMult) + AMult + !-- account for change of weight due two change of var + pmult = pmult * two*(c1+u) + mmult = mmult * two*(c1-u) +4 S16=S16+W(I)*(F(xp)*pmult+F(xm)*mmult) + S16=C2*S16 + IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN + H=H+S16 + IF(BB .NE. B) GO TO 1 + ELSE + BB=C1 + IF(1+CONST*ABS(C2) .NE. 1) GO TO 2 + H=0 + !CALL MTLPRT(NAME,'D113.1','TOO HIGH ACCURACY REQUIRED') + write(0,*) NAME,'D113.1','TOO HIGH ACCURACY REQUIRED' + GO TO 99 + END IF +99 cgauss64=H + end function ig_LinWeightSing + + + !---------------------------------------------------------------------- + ! + ! Integrate F with a polynomial weight function which is zero at all + ! nodes except that indicated by the index inode_one + ! + ! If const is present then it is added to the weight function + Recursive FUNCTION ig_PolyWeight(F,A,B,nodes,inode_one,EPS,wgtadd) result(cgauss64) + real(dp), intent(in) :: A,B,nodes(:),EPS + integer, intent(in) :: inode_one + real(dp), intent(in), optional :: wgtadd + real(dp) :: zero_nodes(size(nodes)-1), norm_nodes, lcl_wgtadd + integer :: i, j + REAL(dp) :: AA,BB,U,C1,C2,S8,S16,H, CGAUSS64, pmult,mmult,Const + real(dp), parameter :: z1 = 1, hf = half*z1, cst = 5*Z1/1000 + real(dp) :: X(12), W(12) + interface + function f(x) + use types; implicit none + real(dp), intent(in) :: x + real(dp) :: f + end function f + end interface + CHARACTER(len=*), parameter :: NAME = 'cgauss64' + + DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ + DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ + DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ + DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ + DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ + DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ + DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ + DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ + DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ + DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ + DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ + DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ + + !-- first set up the structure for the polynomial interpolation-- + j = 0 + do i = 1, size(nodes) + if (i /= inode_one) then + j = j + 1 + zero_nodes(j) = nodes(i) + end if + end do + norm_nodes = 1.0_dp / product(nodes(inode_one) - zero_nodes) + if (present(wgtadd)) then + lcl_wgtadd = wgtadd + else + lcl_wgtadd = zero + end if + + H=0 + IF(B .EQ. A) GO TO 99 + CONST=CST/ABS(B-A) + BB=A +1 AA=BB + BB=B +2 C1=HF*(BB+AA) + C2=HF*(BB-AA) + S8=0 + DO 3 I = 1,4 + U=C2*X(I) + pmult = product(c1+u - zero_nodes) * norm_nodes + lcl_wgtadd + mmult = product(c1-u - zero_nodes) * norm_nodes + lcl_wgtadd +3 S8=S8+W(I)*(F(C1+U)*pmult+F(C1-U)*mmult) + S16=0 + DO 4 I = 5,12 + U=C2*X(I) + pmult = product(c1+u - zero_nodes) * norm_nodes + lcl_wgtadd + mmult = product(c1-u - zero_nodes) * norm_nodes + lcl_wgtadd +4 S16=S16+W(I)*(F(C1+U)*pmult+F(C1-U)*mmult) + S16=C2*S16 + IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN + H=H+S16 + IF(BB .NE. B) GO TO 1 + ELSE + BB=C1 + IF(1+CONST*ABS(C2) .NE. 1) GO TO 2 + H=0 + !CALL MTLPRT(NAME,'D113.1','TOO HIGH ACCURACY REQUIRED') + write(0,*) NAME,'D113.1','TOO HIGH ACCURACY REQUIRED' + GO TO 99 + END IF +99 cgauss64=H + end function ig_PolyWeight + +end module integrator diff --git a/src/interpolation.f90 b/src/interpolation.f90 new file mode 100644 index 0000000..9aa7459 --- /dev/null +++ b/src/interpolation.f90 @@ -0,0 +1,68 @@ +! $Id: interpolation.f90,v 1.3 2002/12/30 17:20:26 gsalam Exp $ +module interpolation + use types + implicit none + private + + public :: uniform_interpolation_weights +contains + + + !-------------------------------------------------------------------- + ! returns the weights for the uniform interpolation, + ! where the first entry of weights corresponds to x=1 + ! and the spacing is 1. + ! + ! formula should be weight(i) = [Prod_{j/=i} (x-j)] (-1)^(n-1) / (i! (n-i)!) + ! + ! Algorithm uses instead [Prod_{j} (x-j)] / (x-i) unless one + ! of the x-i==0 in which case the result is just 0,...,0,,1,0...,0 + ! + ! For simplicity of caching, n == ubound(weights), is limited .le. nmax + subroutine uniform_interpolation_weights(x,weights) + use warnings_and_errors; use consts_dp + real(dp), intent(in) :: x + real(dp), intent(out) :: weights(0:) + !----------------------------------------- + integer, parameter :: nmax = 9 + ! order=n + real(dp), save :: normalisation(0:nmax,0:nmax) = zero + real(dp) :: dists(0:ubound(weights,dim=1)), prod + integer :: n, i + + n = ubound(weights,dim=1) + if (n > nmax) call wae_error('uniform_interpolation_weights',& + &'ubound of weights is too large:',intval=n) + + !-- intialise once for each n + if (normalisation(0,n) == zero) then + !-- calculate factorial + normalisation(0,n) = one + do i = 1, n + normalisation(0,n) = normalisation(0,n) * (-i) + end do + !-- calculate inverse weight "normalisations" + do i = 1, n + normalisation(i,n) = (normalisation(i-1,n) * i)/(i-1-n) + end do + normalisation(:n,n) = one / normalisation(:n,n) + end if + + do i = 0, n + dists(i) = x - i + if (dists(i) == zero) then + weights(:) = zero + weights(i) = one + return + end if + end do + prod = product(dists) + do i = 0, n + weights(i) = prod * normalisation(i,n) / dists(i) + end do + + end subroutine uniform_interpolation_weights + + +end module interpolation + diff --git a/src/mkmk b/src/mkmk new file mode 100755 index 0000000..9973f2b --- /dev/null +++ b/src/mkmk @@ -0,0 +1,2 @@ +#!/bin/sh +makePNEW.perl libdglap.a diff --git a/src/new_as.f90 b/src/new_as.f90 new file mode 100644 index 0000000..2a929ba --- /dev/null +++ b/src/new_as.f90 @@ -0,0 +1,483 @@ +module new_as + use types; use consts_dp + use assertions; use warnings_and_errors + implicit none + private + + type na_segment + real(dp) :: tlo, thi, dt + real(dp) :: beta0, beta1, beta2 + real(dp), pointer :: ra(:) + !-- above iflip we evolve upwards, below iflip we evolve downwards + integer :: iflip, dummy + end type na_segment + + type na_handle + private + type(na_segment), pointer :: seg(:) + integer :: nlo, nhi + integer :: nloop, fixnf + !--- these are startoff parameters + real(dp) :: alfas, Q + real(dp) :: quark_masses(1:6) + real(dp) :: muMatch_mQuark + end type na_handle + + !-- this seems to give reasonable results (c. 10^-9 precision + ! almost everywhere if we start at Z peak) + real(dp) :: dt_base = 0.2_dp + !real(dp), parameter :: dt_base = 0.1_dp + !--------- go from 0.5 GeV to over 10^20 GeV + real(dp), parameter :: tlo = -1.3862944 !-3.2188758_dp + real(dp), parameter :: thi = 93.0_dp + integer, parameter :: nofixnf = -1000000045 + + public :: na_handle + public :: na_Init, na_Value, na_Del, na_NumberOfLoops + public :: na_nfRange, na_nfAtQ, na_QrangeAtNf, na_QuarkMass + public :: na_Set_dt_base + + type(na_segment), pointer :: seg + +contains + + !====================================================================== + !! Set the value of dt_base (used to decide spacings for new coupling + !! instances). + subroutine na_Set_dt_base(new_dt_base) + real(dp) :: new_dt_base + dt_base = new_dt_base + end subroutine na_Set_dt_base + + + !--------------------------------------------------- + subroutine na_Init(nah, alfas, Q, nloop, fixnf, quark_masses, muMatch_mQuark) + use qcd; + type(na_handle), intent(out), target :: nah + real(dp), intent(in), optional :: alfas, Q + integer, intent(in), optional :: nloop, fixnf + real(dp), intent(in), optional :: quark_masses(4:6) + real(dp), intent(in), optional :: muMatch_mQuark + !--------------------------------------------- + !real(dp) :: alfas_lcl, Q_lcl + !integer :: nloop_lcl, fixnf_lcl + !------------------------------- + real(dp) :: alfas_here, lnmatch + real(dp) :: tstart, t, ra + integer :: nf_store + integer :: nbin, i, j, nseg, istart + integer :: nbin_total + + !-- we may well play with nf, so need to be able to reset it + nf_store = nf_int + + nah%alfas = default_or_opt(0.118_dp, alfas) + nah%Q = default_or_opt(91.2_dp, Q) + nah%nloop = default_or_opt(2, nloop) + + nah%fixnf = default_or_opt(nofixnf, fixnf) + + nah%muMatch_mQuark = default_or_opt(one, muMatch_mQuark) + + nah%quark_masses(1:3) = quark_masses_def(1:3) + if (present(quark_masses)) then + nah%quark_masses(4:6) = quark_masses(4:6) + else + nah%quark_masses(4:6) = quark_masses_def(4:6) + end if + + + !-- work out which ranges are needed + ! even in the fixnf case these are used as guides + ! for when to switch dt? + do i = lbound(nah%quark_masses, dim=1), ubound(nah%quark_masses, dim=1) + if (tlo > tOfQ(nah%muMatch_mQuark*nah%quark_masses(i))) nah%nlo = i + if (thi > tOfQ(nah%muMatch_mQuark*nah%quark_masses(i))) nah%nhi = i + end do + + !-- now set up the parameters of the segments + allocate(nah%seg(nah%nlo:nah%nhi)) + nbin_total = 0 + do i = nah%nlo, nah%nhi + seg => nah%seg(i) + nah%seg(i)%tlo = max(tlo, tOfQ(nah%muMatch_mQuark*nah%quark_masses(i))) + if (i < nah%nhi) then + seg%thi = tOfQ(nah%muMatch_mQuark*nah%quark_masses(i+1)) + else + seg%thi = thi + end if + + !-- now fix running coupling + if (nah%fixnf == nofixnf) then + call qcd_SetNf(i) + else + call qcd_SetNf(nah%fixnf) + end if + + !-- lazy person's option for getting number of loops automatically + ! in derivative calculation + seg%beta0 = beta0 + select case(nah%nloop) + case(1) + seg%beta1 = zero + seg%beta2 = zero + case(2) + seg%beta1 = beta1 + seg%beta2 = zero + case(3) + seg%beta1 = beta1 + seg%beta2 = beta2 + case default + call wae_Error('na_init: unsupported number of loops requested') + end select + + !-- first guess, which then needs to be "adapted" to the range + seg%dt = dt_base * half**(6-i) + nbin = ceiling((seg%thi - seg%tlo)/seg%dt) + nbin_total = nbin_total + nbin + seg%dt = (seg%thi - seg%tlo) / nbin + allocate(seg%ra(0:nbin)) + end do + !write(0,*) 'new_as: used total bins ', nbin_total + + !-- find out in which segment we start + tstart = tOfQ(nah%Q) + do i = nah%nlo, nah%nhi + if (tstart <= nah%seg(i)%thi .and. tstart >= nah%seg(i)%tlo) exit + end do + if (i > nah%nhi) & + &call wae_Error('na_init: Specified Q in not in supported range') + nseg = i + + !-- fill up the starting segment + ra = one/nah%alfas + seg => nah%seg(nseg) + istart = nint((tstart-seg%tlo)/seg%dt) + t = tstart + seg%ra(istart) = na_evolve(ra, seg%tlo+istart*seg%dt - tstart) + do i = istart+1, ubound(seg%ra,dim=1) + seg%ra(i) = na_evolve(seg%ra(i-1), seg%dt) + end do + do i = istart-1, lbound(seg%ra,dim=1), -1 + seg%ra(i) = na_evolve(seg%ra(i+1), -seg%dt) + end do + seg%iflip = istart + + !-- fill up the segments above + do j = nseg+1, nah%nhi + seg => nah%seg(j) + alfas_here = one/nah%seg(j-1)%ra(ubound(nah%seg(j-1)%ra,dim=1)) + if (mass_steps_on .and. nah%fixnf == nofixnf) then + !write(0,*) '------ changing as from ',j-1,' to ',j + !write(0,*) j-1, alfas_here + lnmatch = two*log(nah%muMatch_mQuark) + select case (nah%nloop) + case(2) + alfas_here = alfas_here*(1 + alphastep11 * lnmatch * alfas_here) + case(3) + alfas_here = alfas_here*(1 + alphastep11 * lnmatch * alfas_here& + & + (alphastep22 * lnmatch**2 + alphastep21 * lnmatch& + & + alphastep20_pole)*alfas_here**2) + !alfas_here = alfas_here*(1 + alphastep20_pole*alfas_here**2) + end select + !write(0,*) j, alfas_here + end if + seg%ra(0) = one/alfas_here + ! recall that this is the reciprocal of alpha! + do i = 1, ubound(seg%ra,dim=1) + seg%ra(i) = na_evolve(seg%ra(i-1), seg%dt) + end do + seg%iflip = -1 + end do + + !-- fill up the segments below + do j = nseg-1, nah%nlo, -1 + seg => nah%seg(j) + alfas_here = one/nah%seg(j+1)%ra(0) + if (mass_steps_on .and. nah%fixnf == nofixnf) then + !write(0,*) '------ changing as from ',j+1,' to ',j + !write(0,*) j+1, alfas_here + lnmatch = two*log(nah%muMatch_mQuark) + select case (nah%nloop) + case(2) + alfas_here = alfas_here*(1 - alphastep11 * lnmatch * alfas_here) + case(3) + alfas_here = alfas_here*(1 - alphastep11 * lnmatch * alfas_here& + & + (alphastep22 * lnmatch**2 - alphastep21 * lnmatch& + & - alphastep20_pole)*alfas_here**2) + !alfas_here = alfas_here*(1 - alphastep20_pole*alfas_here**2) + end select + !write(0,*) j, alfas_here + end if + seg%ra(ubound(seg%ra,dim=1)) = one/alfas_here + do i = ubound(seg%ra,dim=1)-1, 0, -1 + seg%ra(i) = na_evolve(seg%ra(i+1), -seg%dt) + end do + seg%iflip = ubound(seg%ra,dim=1)+1 + end do + + !--- set things back to their origins + call qcd_SetNf(nf_store) + end subroutine na_init + + + !------------------------------------------------------------------------- + ! If fixnf is present, then the program will force (within limits of +-dt) + ! the alpha that is returned to be that corresponding to fixnf flavours. + ! + ! With smooth matching conditions, this is not a big deal, but with + ! steps at alpha_s thresholds, it is important so that certain D.E. + ! routines (e.g. for PDF evolution) do not give alpha values at end + ! points that give non-smoothness. + function na_Value(nah, Q, fixnf) result(res) + type(na_handle), intent(in), target :: nah + real(dp), intent(in) :: Q + integer, intent(in), optional :: fixnf + real(dp) :: res + !------------------------------------- + real(dp) :: t, trescaled, ra, delta_t + integer :: nseg, i, n + integer, save :: warn_id = warn_id_INIT + integer, parameter :: max_warn = 1 + + t = tOfQ(Q) + + if (present(fixnf) .and. nah%fixnf == nofixnf) then + if (fixnf < nah%nlo .or. fixnf > nah%nhi) then + call wae_error('na_Value:', 'the fixnf requested is& + & outside the range supported this na_handle') + end if + if (t < tlo .or. t > thi) then + call wae_error('na_Value:', 'the Q value is& + & outside the range supported this na_handle') + end if + nseg = fixnf + !if (t > nah%seg(nseg)%thi+ nah%seg(nseg)%dt .or.& + ! & t < nah%seg(nseg)%tlo-nah%seg(nseg)%dt) then + ! call wae_error('na_Value:', & + ! & 'With fixnf, Q is too far outside supported range.') + !end if + else + if (present(fixnf) .and. nah%fixnf /= nofixnf) then + if (fixnf /= nah%fixnf) then + call wae_error('na_Value:', 'the fixnf requested is & + &different from that supported by na_handle') + end if + end if + do nseg = nah%nlo, nah%nhi + if (t <= nah%seg(nseg)%thi .and. t >= nah%seg(nseg)%tlo) exit + end do + if (nseg > nah%nhi) & + &call wae_Error('na_Value: Specified Q is not in supported range'& + &,dbleval=Q) + end if + + seg => nah%seg(nseg) + trescaled = (t - seg%tlo)/seg%dt + if (trescaled > seg%iflip) then + i = floor(trescaled) + else + i = ceiling(trescaled) + end if + i = max(0,min(ubound(seg%ra,dim=1),i)) + + !-- support going well beyond supported limits of this nf, even + ! if the procedure is not particularly recommended. + delta_t = t - (seg%tlo+i*seg%dt) + if (abs(delta_t) <= 1.3_dp*seg%dt) then + res = one/na_evolve(seg%ra(i), delta_t) + else + call wae_warn(max_warn,warn_id,'na_Value: will evolve & + &fixed-nf alpha_s beyond precalculated range.',& + &'This procedure may be very slow') + write(0,*) Qoft(seg%tlo),Qoft(seg%thi),Q + n = ceiling(abs(delta_t/seg%dt)) + delta_t = delta_t/n + ra = seg%ra(i) + do i = 1, n + ra = na_evolve(ra,delta_t) + end do + res = one/ra + end if + !write(0,'(f15.10,i,f15.12)') t, nseg, res ! HOPPER TESTING + end function na_Value + + + !====================================================================== + !! Returns the number of loops in this coupling + integer function na_NumberOfLoops(nah) + type(na_handle), intent(in) :: nah + na_NumberOfLoops = nah%nloop + end function na_NumberOfLoops + + !------------------------------------------------------------- + !! Do all the necessary cleaning up + subroutine na_Del(nah) + type(na_handle), intent(inout) :: nah + integer :: i, status + do i = nah%nlo, nah%nhi + deallocate(nah%seg(i)%ra, stat=status) + end do + deallocate(nah%seg, stat=status) + end subroutine na_Del + + + !====================================================================== + !! Return the mass of the quark specified by iflv + real(dp) function na_QuarkMass(nah,iflv) result(mass) + type(na_handle), intent(in) :: nah + integer, intent(in) :: iflv + if (iflv > 6 .or. iflv < 1) call wae_error('na_QuarkMass', & + &'illegal value for iflv', intval=iflv) + mass = nah%quark_masses(iflv) + end function na_QuarkMass + + + !------------------------------------------------------------- + !! Indicate the range of nf values supported by this handle. + subroutine na_nfRange(nah,nflo,nfhi) + type(na_handle), intent(in) :: nah + integer, intent(out) :: nflo, nfhi + if (nah%fixnf == nofixnf) then + nflo = nah%nlo + nfhi = nah%nhi + else + nflo = nah%fixnf + nfhi = nah%fixnf + end if + end subroutine na_nfRange + + + !------------------------------------------------------------- + !! Returns the number of flavours relevant for scale Q + !! Also returns the range of Qvalues (Qlo, Qhi) for which + !! this value of nf remains the same. + subroutine na_nfAtQ(nah, Q, nfAtQ, Qlo, Qhi, muM_mQ) + type(na_handle), intent(in) :: nah + real(dp), intent(in) :: Q + integer, intent(out) :: nfAtQ + real(dp), intent(out), optional :: Qlo, Qhi + real(dp), intent(in), optional :: muM_mQ + !----------------------------- + real(dp) :: deltat_match + real(dp) :: t + integer :: nseg + real(dp) :: mtlo(nah%nlo:nah%nhi), mthi(nah%nlo:nah%nhi) + + + deltat_match = tofQ(default_or_opt(& + &nah%muMatch_mQuark, muM_mQ)/nah%muMatch_mQuark) + + !-- redefine limits so as to account for requested matching + ! thresholds muM_mQ. Outer limits should not be modified + ! since they are rigidly fixed? + ! + ! What happens if one of these intervals becomes negative? + mtlo(nah%nlo+1:nah%nhi) = nah%seg(nah%nlo+1:nah%nhi)%tlo + deltat_match + mthi(nah%nlo:nah%nhi-1) = nah%seg(nah%nlo:nah%nhi-1)%thi + deltat_match + mtlo(nah%nlo) = nah%seg(nah%nlo)%tlo + mthi(nah%nhi) = nah%seg(nah%nhi)%thi + + t = tOfQ(Q) + if (nah%fixnf == nofixnf) then + do nseg = nah%nlo, nah%nhi + if (t <= mthi(nseg) .and. t >= mtlo(nseg)) exit + end do + if (nseg > nah%nhi) & + &call wae_Error('na_nfAtQ: Specified Q is not in supported range:'& + &,dbleval=Q) + nfAtQ = nseg + if (present(Qlo) .and. present(Qhi)) then + Qlo = QOft(mtlo(nseg)) + Qhi = QOft(mthi(nseg)) + end if + else + if (t > thi .or. t < tlo) then + call wae_Error('na_nfAtQ: Specified Q is not in supported range'& + &,dbleval=Q) + end if + nfAtQ = nah%fixnf + if (present(Qlo) .and. present(Qhi)) then + Qlo = QOft(tlo) + Qhi = QOft(thi) + end if + end if + end subroutine na_nfAtQ + + + !------------------------------------------------------------- + ! returns the Q range for a given value of nf. If supported. + subroutine na_QRangeAtNf(nah, nflcl, Qlo, Qhi, muM_mQ) + type(na_handle), intent(in) :: nah + integer, intent(in) :: nflcl + real(dp), intent(out) :: Qlo, Qhi + real(dp), optional, intent(in) :: muM_mQ + !--------------------------------------- + real(dp) :: deltat_match + character(len=60) :: string + + deltat_match = tofQ(default_or_opt(& + &nah%muMatch_mQuark, muM_mQ)/nah%muMatch_mQuark) + + if (nah%fixnf == nofixnf) then + if (nflcl < nah%nlo .or. nflcl > nah%nhi) then + write(string,'(a,i2,a)') 'nf value ',nflcl,' not supported' + call wae_Error('QrangeAtNf', trim(string)) + end if + if (nflcl == nah%nlo) then + Qlo = QOft(nah%seg(nflcl)%tlo) + else + Qlo = QOft(nah%seg(nflcl)%tlo + deltat_match) + end if + if (nflcl == nah%nhi) then + Qhi = QOft(nah%seg(nflcl)%thi) + else + Qhi = QOft(nah%seg(nflcl)%thi + deltat_match) + end if + else + if (nflcl /= nah%fixnf) then + write(string,'(a,i2,a)') 'nf value ',nflcl,' not supported' + call wae_Error('QrangeAtNf', trim(string)) + end if + Qlo = QOft(tlo) + Qhi = QOft(thi) + end if + end subroutine na_QRangeAtNf + + + !------------------------------------------------------------ + ! given ra return the value evolve by dt + function na_evolve(ra,dt) result(res) + use runge_kutta + real(dp), intent(in) :: ra, dt + !---------------------------------- + real(dp) :: res,t + t = zero + res = ra + call rkstp(dt,t,res,na_deriv) + end function na_evolve + + + + !--------------------------------------------------------- + ! derivative of 1/alpha + subroutine na_deriv(t, ra, dra) + real(dp), intent(in) :: t, ra + real(dp), intent(out) :: dra + + dra = seg%beta0 + seg%beta1/ra + seg%beta2/ra**2 + end subroutine na_deriv + + !-- avoid risk of errors when forgetting factor of two + function tOfQ(Q) + real(dp), intent(in) :: Q + real(dp) :: tOfQ + tOfQ = two * log(Q) + end function tOfQ + function QOft(t) + real(dp), intent(in) :: t + real(dp) :: QOft + QOft = exp(half*t) + end function QOft + +end module new_as diff --git a/src/pdf_general.f90 b/src/pdf_general.f90 new file mode 100644 index 0000000..b2f8cdd --- /dev/null +++ b/src/pdf_general.f90 @@ -0,0 +1,364 @@ +!----------------------------------------------------------- +!! Routines related to allocation and initialisation of parton +!! distributions. +module pdf_general + use types; use consts_dp + !-- do some recycling (actually only the 2d versions will + ! be of any use, but hopefully that will not cause problems) + use convolution + use pdf_representation + implicit none + private + + interface AllocPDF + module procedure pdfgen_AllocPDF_0d, pdfgen_AllocPDF_1d + end interface + public :: AllocPDF + + + interface InitPDF + module procedure pdfgen_InitPDF_, pdfgen_InitPDF_a,& + & pdfgen_InitPDF_ai + end interface + public :: InitPDF + + interface InitPDFSub + module procedure pdfgen_InitPDFSub_, pdfgen_InitPDFSub_a,& + & pdfgen_InitPDFSub_ai + end interface + public :: InitPDFSub + + public :: InitPDF_LHAPDF + + interface AllocInitPDF + module procedure pdfgen_AllocInitPDF_, pdfgen_AllocInitPDF_a,& + & pdfgen_AllocInitPDF_ai + end interface + public :: AllocInitPDF + + interface AllocInitPDFSub + module procedure pdfgen_AllocInitPDFSub_, & + & pdfgen_AllocInitPDFSub_a, pdfgen_AllocInitPDFSub_ai + end interface + public :: AllocInitPDFSub + + interface operator(.anti.) + module procedure pdfgen_anti_0d, pdfgen_anti_1d + end interface + public :: operator(.anti.) +contains + !------------------------------------------------------- + ! allocate a parton distribution; dimensionality refers + ! to extra directions over and above (x,nf). + subroutine pdfgen_AllocPDF_0d(grid,q) + type(grid_def), intent(in) :: grid + real(dp), pointer :: q(:,:) + + call AllocGridQuant(grid,q,ncompmin, ncompmax) + call LabelPdfAsRep(q,pdfr_Human) + end subroutine pdfgen_AllocPDF_0d + + !------------------------------------------------------- + subroutine pdfgen_AllocPDF_1d(grid,q, nl, nh) + type(grid_def), intent(in) :: grid + real(dp), pointer :: q(:,:,:) + integer , intent(in) :: nl, nh + integer :: i + + call AllocGridQuant(grid,q,ncompmin, ncompmax, nl, nh) + do i = nl, nh + call LabelPdfAsRep(q(:,:,i),pdfr_Human) + end do + end subroutine pdfgen_AllocPDF_1d + + + + !---------------------------------------------------------------------- + ! All of these routine just redirect to the official routine, + ! with the added features that they redirect only the components + ! iflv_min:iflv_max, and that they label the result as being in the + ! "Human" representation + recursive subroutine pdfgen_InitPDF_(grid, gq, func) + real(dp), intent(inout) :: gq(0:,ncompmin:) + type(grid_def), intent(in) :: grid + interface + function func(x,n) + use types; implicit none + real(dp), intent(in) :: x + integer , intent(in) :: n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + call InitGridQuant(grid, gq(:,iflv_min:iflv_max), func) + call LabelPdfAsRep(gq,pdfr_Human) + end subroutine pdfgen_InitPDF_ + + !---------------------------------------------------------------------- + ! version intended for use when there is an extra argument whose + ! value is fixed and needs to be passed to func + ! + ! updated for multi + recursive subroutine pdfgen_InitPDF_a(grid, gq, func, axtra) + real(dp), intent(inout) :: gq(0:,ncompmin:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + interface + function func(x,axtra,n) + use types; implicit none + real(dp), intent(in) :: x,axtra + integer , intent(in) :: n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + call InitGridQuant(grid, gq(:,iflv_min:iflv_max), func, axtra) + call LabelPdfAsRep(gq,pdfr_Human) + end subroutine pdfgen_InitPDF_a + + !---------------------------------------------------------------------- + ! version intended for use when there is an extra argument whose + ! value is fixed and needs to be passed to func + ! + ! updated for multi + recursive subroutine pdfgen_InitPDF_ai(grid, gq, func, axtra, ixtra) + real(dp), intent(inout) :: gq(0:,ncompmin:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + integer, intent(in) :: ixtra + interface + function func(x,axtra,ixtra,n) + use types; implicit none + real(dp), intent(in) :: x,axtra + integer , intent(in) :: ixtra,n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + call InitGridQuant(grid, gq(:,iflv_min:iflv_max), func, axtra, ixtra) + call LabelPdfAsRep(gq,pdfr_Human) + end subroutine pdfgen_InitPDF_ai + + + !---------------------------------------------------------------------- + ! updated for multi + recursive subroutine pdfgen_InitPDFSub_(grid, gq, sub) + real(dp), intent(inout) :: gq(0:,ncompmin:) + type(grid_def), intent(in) :: grid + interface + subroutine sub(y,res) + use types; implicit none + real(dp), intent(in) :: y + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + call InitGridQuantSub(grid, gq(:,iflv_min:iflv_max), sub) + call LabelPdfAsRep(gq,pdfr_Human) + end subroutine pdfgen_InitPDFSub_ + + recursive subroutine pdfgen_InitPDFSub_a(grid, gq, sub, axtra) + real(dp), intent(inout) :: gq(0:,ncompmin:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + interface + subroutine sub(y, axtra, res) + use types; implicit none + real(dp), intent(in) :: y, axtra + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + call InitGridQuantSub(grid, gq(:,iflv_min:iflv_max), sub, axtra) + call LabelPdfAsRep(gq,pdfr_Human) + end subroutine pdfgen_InitPDFSub_a + + recursive subroutine pdfgen_InitPDFSub_ai(grid, gq, sub, axtra, ixtra) + real(dp), intent(inout) :: gq(0:,ncompmin:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: axtra + integer, intent(in) :: ixtra + interface + subroutine sub(y, axtra, ixtra, res) + use types; implicit none + real(dp), intent(in) :: y, axtra + integer, intent(in) :: ixtra + real(dp), intent(out) :: res(:) + end subroutine sub + end interface + !----------------------------------------- + call InitGridQuantSub(grid, gq(:,iflv_min:iflv_max), sub, axtra, ixtra) + call LabelPdfAsRep(gq,pdfr_Human) + end subroutine pdfgen_InitPDFSub_ai + + + + !====================================================================== + !! Initialise the subroutine using an LHAPDF style subroutine + subroutine InitPDF_LHAPDF(grid, gq, LHAsub, Q) + real(dp), intent(inout) :: gq(0:,ncompmin:) + type(grid_def), intent(in) :: grid + real(dp), intent(in) :: Q + interface + subroutine LHAsub(x,Q,res) + use types; implicit none + real(dp), intent(in) :: x,Q + real(dp), intent(out) :: res(*) + end subroutine LHAsub + end interface + !------------------------------------------- + call InitGridQuantLHAPDF(grid, gq(:,iflv_min:iflv_max), LHAsub, Q) + call LabelPdfAsRep(gq,pdfr_Human) + end subroutine InitPDF_LHAPDF + + + + + !------------------------------------------------------ + ! allocate and initialise in various forms! + subroutine pdfgen_AllocInitPDF_(grid,q, func) + type(grid_def), intent(in) :: grid + real(dp), pointer :: q(:,:) + interface + function func(y,n) + use types; implicit none + real(dp), intent(in) :: y + integer , intent(in) :: n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + + call AllocPDF(grid,q) + call InitPDF(grid, q, func) + end subroutine pdfgen_AllocInitPDF_ + + !-------------------------------------------------- + subroutine pdfgen_AllocInitPDF_a(grid,q, func, axtra) + type(grid_def), intent(in) :: grid + real(dp), pointer :: q(:,:) + real(dp), intent(in) :: axtra + interface + function func(y,axtra,n) + use types; implicit none + real(dp), intent(in) :: y,axtra + integer , intent(in) :: n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + + call AllocPDF(grid,q) + call InitPDF(grid, q, func, axtra) + end subroutine pdfgen_AllocInitPDF_a + + !------------------------------------------------------------- + subroutine pdfgen_AllocInitPDF_ai(grid,q, func, axtra, ixtra) + type(grid_def), intent(in) :: grid + real(dp), pointer :: q(:,:) + real(dp), intent(in) :: axtra + integer, intent(in) :: ixtra + interface + function func(y,axtra,ixtra,n) + use types; implicit none + real(dp), intent(in) :: y,axtra + integer , intent(in) :: ixtra,n + real(dp) :: func(n) + end function func + end interface + !----------------------------------------- + + call AllocPDF(grid,q) + call InitPDF(grid, q, func, axtra, ixtra) + end subroutine pdfgen_AllocInitPDF_ai + + !------------------------------------------------------ + ! allocate and initialise in various forms! + subroutine pdfgen_AllocInitPDFSub_(grid,q, sub) + type(grid_def), intent(in) :: grid + real(dp), pointer :: q(:,:) + interface + subroutine sub(y,res) + use types; implicit none + real(dp), intent(in) :: y + real(dp), intent(out):: res(:) + end subroutine sub + end interface + !----------------------------------------- + + call AllocPDF(grid,q) + call InitPDFSub(grid, q, sub) + end subroutine pdfgen_AllocInitPDFSub_ + + !-------------------------------------------------- + subroutine pdfgen_AllocInitPDFSub_a(grid,q, sub, axtra) + type(grid_def), intent(in) :: grid + real(dp), pointer :: q(:,:) + real(dp), intent(in) :: axtra + interface + subroutine sub(y,axtra,res) + use types; implicit none + real(dp), intent(in) :: y,axtra + real(dp), intent(out):: res(:) + end subroutine sub + end interface + !----------------------------------------- + + call AllocPDF(grid,q) + call InitPDFSub(grid, q, sub, axtra) + end subroutine pdfgen_AllocInitPDFSub_a + + !------------------------------------------------------------- + subroutine pdfgen_AllocInitPDFSub_ai(grid,q, sub, axtra, ixtra) + type(grid_def), intent(in) :: grid + real(dp), pointer :: q(:,:) + real(dp), intent(in) :: axtra + integer, intent(in) :: ixtra + interface + subroutine sub(y,axtra,ixtra,res) + use types; implicit none + real(dp), intent(in) :: y,axtra + integer , intent(in) :: ixtra + real(dp), intent(out):: res(:) + end subroutine sub + end interface + !----------------------------------------- + + call AllocPDF(grid,q) + call InitPDFSub(grid, q, sub, axtra, ixtra) + end subroutine pdfgen_AllocInitPDFSub_ai + + !--------------------------------------------------- + ! write it out in full rather than using f90 array + ! notation shortcuts to reduce need for assumptions about + ! relation between iflv_min and ncompmin + function pdfgen_anti_0d(q) result(antiq) + real(dp), intent(in) :: q(:,ncompmin:) + real(dp) :: antiq(size(q,1),lbound(q,2):ubound(q,2)) + integer :: i + + !-- try to catch stupid and illegal uses... + if (ubound(q,2) /= ncompmax) call wae_error('pdfgen_anti_0d',& + &'ubound of second dimension of q should be ncompmax, instead it is',& + &intval=ubound(q,2)) + + do i = ncompmin, ncompmax + if (i >= iflv_min .and. i <= iflv_max) then + antiq(:,i) = q(:,-i) + else + antiq(:,i) = q(:,i) + end if + end do + end function pdfgen_anti_0d + + !--------------------------------------------------- + function pdfgen_anti_1d(q) result(antiq) + real(dp), intent(in) :: q(:,ncompmin:,:) + real(dp) :: antiq(size(q,1),lbound(q,2):ubound(q,2),size(q,3)) + integer :: i + do i = 1, size(q,dim=3) + antiq(:,:,i) = pdfgen_anti_0d(q(:,:,i)) + end do + end function pdfgen_anti_1d + +end module pdf_general diff --git a/src/pdf_representation.f90 b/src/pdf_representation.f90 new file mode 100644 index 0000000..1c0eb3d --- /dev/null +++ b/src/pdf_representation.f90 @@ -0,0 +1,288 @@ +!---------------------------------------------------------------------- +! +! This routine stores info about numbers of components used, +! labelling of those components, and more importantly to a general +! used it contains routines for converting between the evolution storage +! format and the "human" storage format +! +! +! $Id: pdf_representation.f90,v 1.5 2003/11/22 00:45:39 salam Exp $ +!---------------------------------------------------------------------- +module pdf_representation + use types; use consts_dp; use assertions; use warnings_and_errors + implicit none + !---------------------------------------------------------------------- + ! As of 6/01/2003, ncompmax and iflv_max must be the same (actually + ! not anymore since we added extra representation iflv_info) + integer, parameter, public :: iflv_max=6 + integer, parameter, public :: iflv_min=-iflv_max + integer, parameter, public :: ncomponents=iflv_max + !------------------------------------------------------ + integer, parameter, public :: iflv_g=0, iflv_sigma=1, iflv_V=-1 + integer, parameter, public :: iflv_d = 1, iflv_u = 2, iflv_s = 3, iflv_c = 4 + integer, parameter, public :: iflv_b = 5, iflv_t = 6 + integer, parameter, public :: iflv_dbar = -iflv_d + integer, parameter, public :: iflv_ubar = -iflv_u + integer, parameter, public :: iflv_sbar = -iflv_s + integer, parameter, public :: iflv_cbar = -iflv_c + integer, parameter, public :: iflv_bbar = -iflv_b + integer, parameter, public :: iflv_tbar = -iflv_t + integer, parameter, public :: iflv_info = iflv_max + 1 + integer, parameter, public :: ncompmin = iflv_min + integer, parameter, public :: ncompmax = iflv_info + + integer, parameter, public :: pdfr_Human = 0 + integer, parameter, public :: pdfr_Evln = 1 + + integer, parameter :: default_ibase = 1 + + + type pdf_rep + integer :: nf, ibase + end type pdf_rep + + public :: pdf_rep + + interface CopyHumanPdfToEvln + module procedure pdfr_HumanToEvln_sc, pdfr_HumanToEvln_1d + module procedure pdfr_HumanToEvln_nf_sc, pdfr_HumanToEvln_nf_1d + end interface + + interface CopyEvlnPdfToHuman + module procedure pdfr_EvlnToHuman_sc, pdfr_EvlnToHuman_1d + module procedure pdfr_EvlnToHuman_nf_sc, pdfr_EvlnToHuman_nf_1d + end interface + + public :: CopyHumanPdfToEvln, CopyEvlnPdfToHuman + public :: GetPdfRep, LabelPdfAsRep + public :: LabelPdfAsHuman + public :: DefaultEvlnRep + +contains + + !====================================================================== + !! return the pdf_rep object corresponding to the default Evln + !! representation for the specified value of nf. + function DefaultEvlnRep(nf_lcl) + integer, intent(in) :: nf_lcl + type(pdf_rep) :: DefaultEvlnRep + DefaultEvlnRep%nf = nf_lcl + DefaultEvlnRep%ibase = default_ibase + end function DefaultEvlnRep + + + + !------------------------------------------------------------------- + !! Take a "human format" pdf set and convert it to a format + !! suitable for evolution, as described near the beginning of + !! dglap_objects. + !! + !! What is called "k" there, here is known as prep%ibase + !! + !! Human format is that produced by the pdf_general module. + !! i.e. (tbar, bbar, cbar, sbar, ubar, dbar, g, d, u, s, c, b, t) + pure subroutine pdfr_HumanToEvln_sc(prep, qh, qe) + type(pdf_rep), intent(in) :: prep + real(dp), intent(in) :: qh(ncompmin:) + real(dp), intent(out) :: qe(ncompmin:) + !---------------------------------------------- + real(dp) :: tmp + real(dp) :: qplus_base, qminus_base + integer :: i, j + + qe(iflv_g) = qh(iflv_g) + qe(iflv_sigma) = sum(qh(1:prep%nf)) + tmp = sum(qh(-prep%nf:-1)) + qe(iflv_V) = qe(iflv_sigma) - tmp + qe(iflv_sigma) = qe(iflv_sigma) + tmp + + qplus_base = qh(prep%ibase) + qh(-prep%ibase) + qminus_base = qh(prep%ibase) - qh(-prep%ibase) + do i = 2, prep%nf + if (i > prep%ibase) then + j = i + else + j = i-1 + end if + qe( i) = qh(j) + qh(-j) - qplus_base + qe(-i) = qh(j) - qh(-j) - qminus_base + end do + !-- keep the rest clean... + do i = prep%nf+1, ncomponents + !qe(i) = zero + !qe(-i) = zero + qe(i) = qh(i) + qe(-i) = qh(-i) + end do + + end subroutine pdfr_HumanToEvln_sc + + !------------------------------------------------ + !! a vector version of the above + subroutine pdfr_HumanToEvln_1d(prep, qh, qe) + type(pdf_rep), intent(in) :: prep + real(dp), intent(in) :: qh(:,ncompmin:) + real(dp), intent(out) :: qe(:,ncompmin:) + integer :: n, i + + n = assert_eq(size(qh,dim=1),size(qe,dim=1),'pdfr_HumanToEvln_1d') + if (GetPdfRep(qh) /= pdfr_Human) call wae_error('pdfr_HumanToEvln_1d',& + &'qh is not in "Human" format') + + do i = 1, n + call pdfr_HumanToEvln_sc(prep, qh(i,:), qe(i,:)) + end do + call LabelPdfAsRep(qe,pdfr_Evln) + end subroutine pdfr_HumanToEvln_1d + + + !--------------------------------------------------------- + !! Take a pdf set in "evolution format" and convert it back + !! to "human format". + subroutine pdfr_EvlnToHuman_sc(prep, qe, qh) + type(pdf_rep), intent(in) :: prep + real(dp), intent(in) :: qe(ncompmin:) + real(dp), intent(out) :: qh(ncompmin:) + !--------------------------------------------- + integer :: i, j + real(dp) :: tmp + + qh(iflv_g) = qe(iflv_g) + !-- first construct individual + and - distributions + qh( prep%ibase) = (qe(iflv_sigma) - sum(qe(2:prep%nf)) )/prep%nf + qh(-prep%ibase) = (qe(iflv_V) - sum(qe(-prep%nf:-2)) )/prep%nf + + do i = 2, prep%nf + if (i > prep%ibase) then + j = i + else + j = i-1 + end if + qh( j) = qe( i) + qh( prep%ibase) + qh(-j) = qe(-i) + qh(-prep%ibase) + end do + + !-- then go from + and - to q and qbar + do i = 1, prep%nf + tmp = qh(-i) + qh(-i) = half*(qh(i) - tmp) + qh( i) = half*(qh(i) + tmp) + end do + + !-- make sure the rest is zero + do i = prep%nf+1, iflv_max + !qh( i) = zero + !qh(-i) = zero + qh( i) = qe(i) + qh(-i) = qe(-i) + end do + + end subroutine pdfr_EvlnToHuman_sc + + + !------------------------------------------------ + !! a vector version of the above + subroutine pdfr_EvlnToHuman_1d(prep, qe, qh) + type(pdf_rep), intent(in) :: prep + real(dp), intent(in) :: qe(:,ncompmin:) + real(dp), intent(out) :: qh(:,ncompmin:) + integer :: n, i + n = assert_eq(size(qh,dim=1),size(qe,dim=1),'pdfr_EvlnToHuman_1d') + if (GetPdfRep(qe) /= pdfr_Evln) call wae_error('pdf_EvlnToHuman_1d',& + &'qe is not in "Evln" format') + do i = 1, n + call pdfr_EvlnToHuman_sc(prep, qe(i,:), qh(i,:)) + end do + call LabelPdfAsRep(qh,pdfr_Human) + end subroutine pdfr_EvlnToHuman_1d + + + !=== next follow overloaded versions with integer (nf) spec of rep + subroutine pdfr_HumanToEvln_nf_sc(nf_lcl, qh, qe) + integer , intent(in) :: nf_lcl + real(dp), intent(in) :: qh(:) + real(dp), intent(out) :: qe(:) + call CopyHumanPdfToEvln(DefaultEvlnRep(nf_lcl), qh, qe) + end subroutine pdfr_HumanToEvln_nf_sc + ! + subroutine pdfr_HumanToEvln_nf_1d(nf_lcl, qh, qe) + integer , intent(in) :: nf_lcl + real(dp), intent(in) :: qh(:,:) + real(dp), intent(out) :: qe(:,:) + call CopyHumanPdfToEvln(DefaultEvlnRep(nf_lcl), qh, qe) + end subroutine pdfr_HumanToEvln_nf_1d + ! + subroutine pdfr_EvlnToHuman_nf_sc(nf_lcl, qe, qh) + integer , intent(in) :: nf_lcl + real(dp), intent(in) :: qe(:) + real(dp), intent(out) :: qh(:) + call CopyEvlnPdfToHuman(DefaultEvlnRep(nf_lcl), qe, qh) + end subroutine pdfr_EvlnToHuman_nf_sc + ! + subroutine pdfr_EvlnToHuman_nf_1d(nf_lcl, qe, qh) + integer , intent(in) :: nf_lcl + real(dp), intent(in) :: qe(:,:) + real(dp), intent(out) :: qh(:,:) + call CopyEvlnPdfToHuman(DefaultEvlnRep(nf_lcl), qe, qh) + end subroutine pdfr_EvlnToHuman_nf_1d + + + + !-------------------------------------------------------------- + !! Label the pdf with a "key" corresponding to the representation + !! Make part of Evln the key random so that if we subtract two pdfs + !! in the Evln representation they will not accidentally give + !! something in the human representation. + subroutine LabelPdfAsRep(q,irep) + use random + real(dp), intent(inout) :: q(0:,ncompmin:) + integer, intent(in) :: irep + + if (ubound(q,dim=2) /= ncompmax) call wae_error('LabelPdfAsRep',& + &'upper bound of q does not correspond to ncompmax; it is:',& + &intval=ubound(q,dim=2)) + + ! very wasteful labelling, but in f90 it is hard to see + ! what else can be done... + select case(irep) + case(pdfr_Human) + q(:,iflv_info) = zero + case(pdfr_Evln) + q(0,iflv_info) = pi*1e-1_dp + q(1,iflv_info) = one+ran() + q(2:,iflv_info) = zero + case default + call wae_error('LabelPdfAsRep','Unrecognized irep:',intval=irep) + end select + end subroutine LabelPdfAsRep + + + !====================================================================== + !! Label the PDF as being in the human representation + subroutine LabelPdfAsHuman(q) + real(dp), intent(inout) :: q(0:,ncompmin:) + call LabelPdfAsRep(q,pdfr_human) + end subroutine LabelPdfAsHuman + + !------------------------------------------------------------- + !! This tells us what representation it is in + function GetPdfRep(q) result(irep) + real(dp), intent(in) :: q(0:,ncompmin:) + integer :: irep + + if (ubound(q,dim=2) /= ncompmax) call wae_error('GetPdfRep',& + &'upper bound of q does not correspond to ncompmax; it is:',& + &intval=ubound(q,dim=2)) + + !if (q(0,iflv_info) == zero .neqv. q(1,iflv_info) == zero) then + ! call wae_error('GetPdfRep', 'Inconsistent behaviour in iflv_info') + !else + if (q(0,iflv_info) == zero .and. q(1,iflv_info) == zero) then + irep = pdfr_Human + else + irep = pdfr_Evln + end if + end function GetPdfRep + + +end module pdf_representation diff --git a/src/pdf_tabulate.f90 b/src/pdf_tabulate.f90 new file mode 100644 index 0000000..e2c009c --- /dev/null +++ b/src/pdf_tabulate.f90 @@ -0,0 +1,792 @@ +!----------------------------------------------------------- +!! Module that will hopefully make tabulation easy +!! +!! Currently does not know anything about nf thresholds. +!! +!! But some form of support for these might be useful... Question is: +!! how can it be arranged in a fairly clean manner, without breaking +!! things that already use the system (e.g. caesar resum)? +!! +!! One possibility is to use an running_coupling as a source of information. +!! One can then either take a copy of the running_coupling and use its routines +!! or else just extract the relevant useful information +!! +!! Aim is to be able to write -- i.e. convolutions with full nf info +!! +!! Ptab%tab = dh%P_LO(iloop,tab%nf_int(:)) .conv. tab%tab +!! +!! This probably requires some modifications also to the convolution +!! routines (which do not currently have this overloading for .conv.). +!! +!! [NB at some point maybe include nf association in some simpler manner?] +module pdf_tabulate_new + use types; use consts_dp + use convolution; use dglap_objects + use pdf_representation; use pdf_general + use interpolation + use warnings_and_errors + !-- needed only for pdftab_InitTabEvolve [separate it out one day?] + use qcd_coupling; use evolution; use dglap_holders + implicit none + private + + + type pdfseginfo + real(dp) :: lnlnQ_lo, lnlnQ_hi, dlnlnQ + integer :: ilnlnQ_lo, ilnlnQ_hi + end type pdfseginfo + public :: pdfseginfo + + type pdftab + ! basic elements of a pdftab, common regardless of whether we + ! additionally have the nf segments... + type(grid_def) :: grid + real(dp) :: default_dlnlnQ + real(dp) :: lnlnQ_min, lnlnQ_max, lambda_eff + real(dp), pointer :: tab(:,:,:) + real(dp), pointer :: lnlnQ_vals(:) + integer :: nQ, lnlnQ_order + logical :: freeze_at_Qmin + ! this is useful only in absence of nf info. + real(dp) :: dlnlnQ + ! + ! Stuff to do with variable nf and alpha_s; not always available. + ! In cases with variable nf, the table will be broken into multiple + ! segments, each one of which potentially different spacings. + ! + logical :: nf_info_associated + integer :: nflo, nfhi + type(pdfseginfo), pointer :: seginfo(:) + integer, pointer :: nf_int(:) + real(dp), pointer :: as2pi(:) + ! + ! Elements needed in case we want to do precalculation of + ! of evolution. Not always available. + type(evln_operator), pointer :: evops(:) + integer :: StartScale_iQlo + real(dp) :: StartScale + end type pdftab + public :: pdftab + + !-- for calculating ln ln Q/lambda_eff + real(dp), parameter :: default_lambda_eff = 0.1_dp + real(dp), parameter :: default_dlnlnQ = 0.1_dp + real(dp), parameter :: warn_tolerance = 1e-3_dp + ! used in various contexts for deciding when an interval is + ! sufficiently small that it can be ignored... + real(dp), parameter :: min_dlnlnQ_singleQ = 1e-10_dp + integer, parameter :: def_lnlnQ_order = 3 + !integer, parameter :: lnlnQ_order = 2 + + interface pdftab_AllocTab + module procedure pdftab_AllocTab_, pdftab_AllocTab_fromorig,& + & pdftab_AllocTab_1d, pdftab_AllocTab_fromorig_1d + end interface + + interface pdftab_AssocNfInfo + module procedure pdftab_AssocNfInfo, pdftab_AssocNfInfo_1d + end interface + + interface pdftab_InitTabSub + module procedure pdftab_InitTabSub_, pdftab_InitTabSub_iset + end interface + + public :: pdftab_InitTab_LHAPDF + + interface pdftab_InitTabEvolve + module procedure pdftab_InitTabEvolve_frompre, pdftab_InitTabEvolve + end interface + + interface Delete + module procedure pdftab_DelTab_0d, pdftab_DelTab_1d + end interface + + public :: pdftab_AllocTab, pdftab_InitTabSub + public :: pdftab_AssocNfInfo + public :: pdftab_InitTabEvolve, pdftab_PreEvolve + public :: pdftab_TabEvolveGen + public :: pdftab_ValTab_yQ, pdftab_ValTab_xQ + public :: Delete + +contains + + !--------------------------------------------------------- + !! Allocate a pdftab, which covers a range Qmin to Qmax, using + !! tabulation uniform in (ln ln Q/Lambda), where Lambda is currently + !! a module parameter. + !! + !! If freeze_at_Qmin is present and .true., distributions are frozen + !! at their Qmin value for Q < Qmin. Otherwise they are set to zero + !! there. + !! + !! More sensible extrapolation beyond Q range offers scope for future + !! improvement here! + !! + subroutine pdftab_AllocTab_(grid, tab, Qmin, Qmax, dlnlnQ, freeze_at_Qmin, lnlnQ_order) + type(grid_def), intent(in) :: grid + type(pdftab), intent(out) :: tab + real(dp), intent(in) :: Qmin, Qmax + real(dp), intent(in), optional :: dlnlnQ + logical, intent(in), optional :: freeze_at_Qmin + integer, intent(in), optional :: lnlnQ_order + !---------------------------------------------- + integer :: iQ + tab%grid = grid + tab%lambda_eff = min(half*Qmin, default_lambda_eff) + tab%lnlnQ_min = lnln(tab,Qmin) + tab%lnlnQ_max = lnln(tab,Qmax) + + tab%default_dlnlnQ = default_or_opt(default_dlnlnQ, dlnlnQ) + tab%nQ = ceiling((tab%lnlnQ_max - tab%lnlnQ_min)/tab%default_dlnlnQ) + tab%dlnlnQ = (tab%lnlnQ_max - tab%lnlnQ_min)/tab%nQ + tab%freeze_at_Qmin = default_or_opt(.false.,freeze_at_Qmin) + tab%lnlnQ_order = default_or_opt(def_lnlnQ_order,lnlnQ_order) + + !-- by default, no extra info is given + tab%nf_info_associated = .false. + nullify(tab%as2pi) + nullify(tab%nf_int) + nullify(tab%evops) + + !write(0,*) 'pdftab info: Number of Q bins is ',tab%nQ + call AllocPDF(grid,tab%tab,0,tab%nQ) + allocate(tab%lnlnQ_vals(0:tab%nQ)) + do iQ = 0, tab%nQ + tab%lnlnQ_vals(iQ) = tab%lnlnQ_min + iQ * tab%dlnlnQ + end do + + end subroutine pdftab_AllocTab_ + + + + !--------------------------------------------------------- + !! 1d overloaded version of pdftab_AllocTab + subroutine pdftab_AllocTab_1d(grid, tab, Qmin, Qmax, dlnlnQ, freeze_at_Qmin) + type(grid_def), intent(in) :: grid + type(pdftab), intent(out) :: tab(:) + real(dp), intent(in) :: Qmin, Qmax + real(dp), intent(in), optional :: dlnlnQ + logical, intent(in), optional :: freeze_at_Qmin + integer :: i + + do i = 1, size(tab) + call pdftab_AllocTab_(grid, tab(i), Qmin, Qmax, dlnlnQ, freeze_at_Qmin) + end do + end subroutine pdftab_AllocTab_1d + + + !--------------------------------------------------------------- + !! Associate a tab with the nf info from an alpha_s holder + !! (i.e. read that info, and copy it into tab). + !! + !! This involves REALLOCATING the tab pointer so as to allow for + !! extra information. + !! + !! The new tab separates stretches with different nf values. It also + !! has extra info in the form of arrays nf_int and as2pi, which make + !! it possible to write expressions such as + !! + !! Dtab%tab = tab%as2pi(:) * (dh%P_LO(iloop,tab%nf_int(:)) .conv. tab%tab) + !! + !! This is one of the rare cases in which direct access to structure + !! components is still allowed... (Lack of finalisation makes it + !! difficult to do otherwise). + !! + !! KNOWN LIMITATIONS: What happens with muM_mQ /= 1? All hell breaks + !! loose? + subroutine pdftab_AssocNfInfo(tab,coupling) + type(pdftab), intent(inout) :: tab + type(running_coupling), intent(in) :: coupling + !----------------------------------- + integer :: nflcl, iQ_prev, iQ + real(dp) :: Qlo, Qhi, Qhi_test + type(pdfseginfo), pointer :: seginfo + + + if (tab%nf_info_associated) call wae_error('pdftab_AssocNfInfo',& + &'nf info already associated: delete it first') + + ! We will be reallocating everything here, so first clean up + call Delete(tab) + tab%dlnlnQ = zero ! will no longer be useful... + + tab%nflo = NfAtQ(coupling, invlnln(tab,tab%lnlnQ_min)) + tab%nfhi = NfAtQ(coupling, invlnln(tab,tab%lnlnQ_max)) + + allocate(tab%seginfo(tab%nflo:tab%nfhi)) + + ! figure out how we are going to bin things... + iQ_prev = -1 + do nflcl = tab%nflo, tab%nfhi + !write(0,*) 'nflcl',nflcl + seginfo => tab%seginfo(nflcl) + + call QRangeAtNf(coupling, nflcl, Qlo, Qhi_test) + call QRangeAtNf(coupling, nflcl, Qlo, Qhi, muM_mQ=one) + ! if one weakens this restriction, then one should think about + ! the consequences for the determination of alpha_s/2pi, here + ! and elsewhere.... + if (Qhi_test /= Qhi) call wae_error('pdftab_AssocNfInfo',& + &'it seems that coupling has muM_mQ /= one. Currently unsupported.',& + &dbleval=Qhi_test/Qhi) + + ! Include min_dlnlnQ_singleQ to ensure we do not go EXACTLY to the + ! mass threshold, where, in evolution one might run into problems. + ! BUT, we will later have to worry about what to do when we + ! are in between thresholds... + seginfo%lnlnQ_lo = max(lnln(tab,Qlo)+min_dlnlnQ_singleQ, tab%lnlnQ_min) + seginfo%lnlnQ_hi = min(lnln(tab,Qhi)-min_dlnlnQ_singleQ, tab%lnlnQ_max) + + seginfo%ilnlnQ_lo = iQ_prev + 1 + !write(0,*) 'ill_lo', seginfo%ilnlnQ_lo + if ((seginfo%lnlnQ_hi - seginfo%lnlnQ_lo) < two*min_dlnlnQ_singleQ) then + ! use just one point + seginfo%ilnlnQ_hi = seginfo%ilnlnQ_lo + seginfo%dlnlnQ = zero + seginfo%lnlnQ_hi = seginfo%lnlnQ_lo + else + seginfo%ilnlnQ_hi = seginfo%ilnlnQ_lo + max(tab%lnlnQ_order,& + & ceiling((seginfo%lnlnQ_hi - seginfo%lnlnQ_lo)/& + & tab%default_dlnlnQ)) + seginfo%dlnlnQ = (seginfo%lnlnQ_hi - seginfo%lnlnQ_lo)/& + & (seginfo%ilnlnQ_hi - seginfo%ilnlnQ_lo) + end if + !write(0,*) 'ill_hi', seginfo%ilnlnQ_hi, seginfo%dlnlnQ, & + ! &invlnln(tab,seginfo%lnlnQ_lo),invlnln(tab,seginfo%lnlnQ_hi), tab%default_dlnlnQ + iQ_prev = seginfo%ilnlnQ_hi + end do + + ! this should not happen too often! But check it just in + ! case... + if (tab%seginfo(tab%nflo)%lnlnQ_lo /= tab%lnlnQ_min .or.& + &tab%seginfo(tab%nfhi)%lnlnQ_hi /= tab%lnlnQ_max) & + &call wae_error('pdftab_AssocNfInfo',& + & 'mismatch in segment and global lnlnQ limits.',& + & 'Could be due coupling having more restricted range?') + + + ! now reallocate things? + tab%nQ = tab%seginfo(tab%nfhi)%ilnlnQ_hi + call AllocPDF(tab%grid,tab%tab,0,tab%nQ) + allocate(tab%lnlnQ_vals(0:tab%nQ)) + allocate(tab%nf_int(0:tab%nQ)) + allocate(tab%as2pi(0:tab%nQ)) + + ! set up complementary info... + do nflcl = tab%nflo, tab%nfhi + !write(0,*) 'nflcl',nflcl + seginfo => tab%seginfo(nflcl) + do iQ = seginfo%ilnlnQ_lo, seginfo%ilnlnQ_hi + tab%nf_int(iQ) = nflcl + tab%lnlnQ_vals(iQ) = seginfo%lnlnQ_lo & + & + (iQ-seginfo%ilnlnQ_lo)*seginfo%dlnlnQ + tab%as2pi(iQ) = Value(coupling,invlnln(tab,tab%lnlnQ_vals(iQ)))/twopi + end do + end do + + ! REMEMBER TO COMPLETE FROM ORIG... + tab%nf_info_associated = .true. + write(0,*) 'pdftab info: Number of Q bins changed to',tab%nQ + end subroutine pdftab_AssocNfInfo + + + !--------------------------------------------------------------- + !! 1d-overloaded verseion of pdftab_AssocNfInfo + subroutine pdftab_AssocNfInfo_1d(tab,coupling) + type(pdftab), intent(inout) :: tab(:) + type(running_coupling), intent(in) :: coupling + !----------------------------------- + integer :: i + do i = 1, size(tab) + call pdftab_AssocNfInfo(tab(i),coupling) + end do + + end subroutine pdftab_AssocNfInfo_1d + + + !----------------------------------------------------------------------- + !! Allocate the memory for a new tab, using as a template an + !! preexistent tab (origtab). + !! + !! Additionally, information concerning any varnf and alphas + !! structure copied from origtab to tab. Actual PDF contents of the + !! tab are not however copied. + !! + subroutine pdftab_AllocTab_fromorig(tab, origtab) + type(pdftab), intent(out) :: tab + type(pdftab), intent(in) :: origtab + + tab = origtab + !-- this is the only thing that is not taken care of... + call AllocPDF(tab%grid,tab%tab,0,tab%nQ) + allocate(tab%lnlnQ_vals(0:tab%nQ)) + tab%lnlnQ_vals = origtab%lnlnQ_vals + + if (origtab%nf_info_associated) then + allocate(tab%seginfo(tab%nflo:tab%nfhi)) + allocate(tab%nf_int(0:tab%nQ)) + allocate(tab%as2pi(0:tab%nQ)) + tab%seginfo = origtab%seginfo + tab%nf_int = origtab%nf_int + tab%as2pi = origtab%as2pi + end if + end subroutine pdftab_AllocTab_fromorig + + !--------------------------------------------------------- + !! 1d-overloaded version of pdftab_AllocTab_fromorig + subroutine pdftab_AllocTab_fromorig_1d(tab, origtab) + type(pdftab), intent(out) :: tab(:) + type(pdftab), intent(in) :: origtab + integer :: i + do i = 1, size(tab) + call pdftab_AllocTab_fromorig(tab(i), origtab) + end do + end subroutine pdftab_AllocTab_fromorig_1d + + + !------------------------------------------------------ + !! Initialise the tab with the results of a subroutine (see + !! interface). Note that the subroutine takes y = ln1/x and Q as its + !! arguments. + subroutine pdftab_InitTabSub_(tab, sub) + type(pdftab), intent(inout) :: tab + interface + subroutine sub(y, Q, res) + use types; implicit none + real(dp), intent(in) :: y, Q + real(dp), intent(out):: res(:) + end subroutine sub + end interface + !------------- + integer :: iQ + real(dp) :: Q + do iQ = 0, tab%nQ + Q = invlnln(tab,tab%lnlnQ_min + iQ*tab%dlnlnQ) + call InitPDFSub(tab%grid, tab%tab(:,:,iQ), sub, Q) + end do + + end subroutine pdftab_InitTabSub_ + + !------------------------------------------------------ + !! Initialise the tab with the results of a subroutine (see + !! interface). In addition y = ln1/x and Q, the subroutine takes the + !! argument iset, enabling one to initialise from a subroutine that + !! provides several "PDF sets". + !! + subroutine pdftab_InitTabSub_iset(tab, sub, iset) + type(pdftab), intent(inout) :: tab + integer, intent(in) :: iset + interface + subroutine sub(y, Q, iset, res) + use types; implicit none + real(dp), intent(in) :: y, Q + integer, intent(in) :: iset + real(dp), intent(out):: res(:) + end subroutine sub + end interface + !------------- + integer :: iQ + real(dp) :: Q + do iQ = 0, tab%nQ + !Q = invlnln(tab,tab%lnlnQ_min + iQ*tab%dlnlnQ) + Q = invlnln(tab,tab%lnlnQ_vals(iQ)) + call InitPDFSub(tab%grid, tab%tab(:,:,iQ), sub, Q, iset) + end do + + end subroutine pdftab_InitTabSub_iset + + !------------------------------------------------------ + !! Initialise the tab with the results of a subroutine (see + !! interface). Note that the subroutine takes y = ln1/x and Q as its + !! arguments. + subroutine pdftab_InitTab_LHAPDF(tab, LHAsub) + type(pdftab), intent(inout) :: tab + interface + subroutine LHAsub(x,Q,res) + use types; implicit none + real(dp), intent(in) :: x,Q + real(dp), intent(out) :: res(*) + end subroutine LHAsub + end interface + !------------- + integer :: iQ + real(dp) :: Q + do iQ = 0, tab%nQ + Q = invlnln(tab,tab%lnlnQ_min + iQ*tab%dlnlnQ) + call InitPDF_LHAPDF(tab%grid, tab%tab(:,:,iQ), LHAsub, Q) + end do + end subroutine pdftab_InitTab_LHAPDF + + !--------------------------------------------------------------------- + !! Given a starting distribution, StartDist, at StartScale and an + !! "coupling" determining the behaviour of alphas, fill in the tab with + !! the evolution of the starting distribution. Most of the arguments + !! have meanings similar to those in the evolution routines + !! + subroutine pdftab_InitTabEvolve(tab, StartScale, StartDist, & + & dh, coupling, muR_Q,nloop, untie_nf) + type(pdftab), intent(inout) :: tab + real(dp), intent(in) :: StartScale + real(dp), intent(in) :: StartDist(0:,iflv_min:) + type(dglap_holder), intent(in) :: dh + type(running_coupling), intent(in) :: coupling + real(dp), intent(in), optional :: muR_Q + integer, intent(in), optional :: nloop + logical, intent(in), optional :: untie_nf + !----------------------------------------------------- + + call pdftab_TabEvolveGen(tab, StartScale, dh, coupling, & + &StartDist=StartDist, muR_Q=muR_Q, nloop=nloop, untie_nf=untie_nf) + end subroutine pdftab_InitTabEvolve + + !--------------------------------------------------------------------- + !! Given a starting scale, precalculate the evolution operators that + !! are needed to generate the full tab from a distribution at that + !! starting scale . Most of the arguments have meanings similar + !! to those in the evolution routines + !! + subroutine pdftab_PreEvolve(tab,StartScale,dh,coupling,muR_Q,nloop,untie_nf) + type(pdftab), intent(inout) :: tab + real(dp), intent(in) :: StartScale + type(dglap_holder), intent(in) :: dh + type(running_coupling), intent(in) :: coupling + real(dp), intent(in), optional :: muR_Q + integer, intent(in), optional :: nloop + logical, intent(in), optional :: untie_nf + !----------------------------------------------------- + + call pdftab_TabEvolveGen(tab, StartScale, dh, coupling, & + &precalc = .true., muR_Q=muR_Q, nloop = nloop, untie_nf=untie_nf) + end subroutine pdftab_PreEvolve + + !--------------------------------------------------------------------- + !! Given a starting distribution, StartDist, and assuming that the + !! pre-evolution has been carried out for the tab, then generate the + !! contents of the table from the StartDist. + !! + !! NB: alphas will not be updated relative to last true evolution or + !! preevolution. So if at any point since doing the preevolution, + !! an evolution has been carried out with a different alphas, then + !! as2pi will not be correct here. SHOULD THIS BE FIXED? + !! + subroutine pdftab_InitTabEvolve_frompre(tab, StartDist) + type(pdftab), intent(inout) :: tab + real(dp), intent(in) :: StartDist(0:,iflv_min:) + !----------------------------------------------------- + real(dp) :: dist(0:ubound(StartDist,1),iflv_min:ubound(StartDist,2)) + integer :: iQ + + if (.not. associated(tab%evops)) call wae_error(& + &'pdftab_InitTabEvolve_frompre',& + &'No precalculated evolution is available') + + dist = StartDist + do iQ = tab%StartScale_iQlo, 0, -1 + dist = tab%evops(iQ) .conv. dist + tab%tab(:,:,iQ) = dist + end do + dist = StartDist + do iQ = tab%StartScale_iQlo+1, tab%nQ + dist = tab%evops(iQ) .conv. dist + tab%tab(:,:,iQ) = dist + end do + + end subroutine pdftab_InitTabEvolve_frompre + + !--------------------------------------------------------------------- + !! General internal routine, which serves both to carry out evolution + !! of a parton distribution AND to determine the evops. That way + !! everything to do with evolution is concentrated in a single location. + !! + !! For the user, this routine should probably be accessed via the more + !! specific routines, pdftab_InitTabEvolve and pdftab_PreCalc. + !! + !! Given a starting distribution, StartDist, at StartScale and an + !! "coupling" determining the behaviour of alphas, fill in the tab with + !! the evolution of the starting distribution. + !! + subroutine pdftab_TabEvolveGen(tab, StartScale, dh, coupling, & + &StartDist, precalc, muR_Q, nloop, untie_nf) + type(pdftab), intent(inout) :: tab + real(dp), intent(in) :: StartScale + type(dglap_holder), intent(in) :: dh + type(running_coupling), intent(in) :: coupling + !real(dp), optional, intent(in) :: StartDist(0:,iflv_min:) + real(dp), optional, intent(in) :: StartDist(:,:) + logical, optional, intent(in) :: precalc + real(dp), optional, intent(in) :: muR_Q + integer, optional, intent(in) :: nloop + logical, optional, intent(in) :: untie_nf + !----------------------------------------------------- + real(dp), allocatable :: dist(:,:) + real(dp) :: lnlnQ_norm, lnlnQ, Q_init, Q_end, last_Q + integer :: i, iQ_lo, iQ_hi + logical :: precalc_lcl + + precalc_lcl = default_or_opt(.false.,precalc) + if (precalc_lcl) then + if (associated(tab%evops)) call wae_error('pdftab_TabEvolveGen',& + &'tab%evops has already been calculated. Delete the tab first,',& + &'if you want to recalculated it.') + allocate(tab%evops(0:tab%nQ)) + end if + + + lnlnQ = lnln(tab,StartScale) + call request_iQrange(tab, lnlnQ, 1, iQ_lo, iQ_hi, lnlnQ_norm) + tab%StartScale = StartScale + tab%StartScale_iQlo = iQ_lo + ! force this... + iQ_hi = iQ_lo + 1 + !write(0,*) iQ_lo, iQ_hi + !lnlnQ_norm_start = lnln_norm(tab,StartScale) + + + if (present(StartDist)) then + allocate(dist(size(StartDist,1),size(StartDist,2))) + dist = StartDist + end if + + last_Q = StartScale + !do i = floor(lnlnQ_norm_start), 0, -1 + do i = iQ_lo, 0, -1 + Q_init = last_Q + Q_end = invlnln(tab,tab%lnlnQ_vals(i)) + !write(0,*) 'doing ev from ',Q_init,' to', Q_end + + if (present(StartDist)) then + call EvolvePDF(dh, dist, & + & coupling, Q_init, Q_end, muR_Q, nloop, untie_nf) + tab%tab(:,:,i) = dist + end if + + if (precalc_lcl) call EvolveGeneric(dh, & + &coupling, Q_init, Q_end, evop=tab%evops(i), & + &muR_Q = muR_Q, nloop = nloop, untie_nf = untie_nf) + + if (tab%nf_info_associated) tab%as2pi(i) = Value(coupling,Q_end)/twopi + last_Q = Q_end + end do + + + if (present(StartDist)) dist = StartDist + last_Q = StartScale + !do i = ceiling(lnlnQ_norm_start), tab%nQ + do i = iQ_hi, tab%nQ + Q_init = last_Q + Q_end = invlnln(tab,tab%lnlnQ_vals(i)) + !write(0,*) 'doing ev from ',Q_init,' to', Q_end + + !write(0,*) 'doing ev from ',Q_init,' to', Q_end + if (present(StartDist)) then + call EvolvePDF(dh, dist,& + & coupling, Q_init, Q_end, muR_Q, nloop, untie_nf) + tab%tab(:,:,i) = dist + end if + + if (precalc_lcl) call EvolveGeneric(dh, & + &coupling, Q_init, Q_end, evop=tab%evops(i), & + &muR_Q = muR_Q, nloop = nloop, untie_nf = untie_nf) + + if (tab%nf_info_associated) tab%as2pi(i) = Value(coupling,Q_end)/twopi + last_Q = Q_end + end do + + if (present(StartDist)) deallocate(dist) + end subroutine pdftab_TabEvolveGen + + + !-------------------------------------------------------------------- + !! Returns a vector val(iflv_min:iflv_max) for the PDF at this + !! y=ln1/x,Q. + subroutine pdftab_ValTab_yQ(tab,y,Q,val) + type(pdftab), intent(in) :: tab + real(dp), intent(in) :: y, Q + real(dp), intent(out) :: val(iflv_min:) + !---------------------------------------- + real(dp) :: lnlnQ, lnlnQ_norm + real(dp) :: lnlnQ_wgts(0:tab%lnlnQ_order) + real(dp), pointer :: y_wgts(:) + real(dp), allocatable :: wgts(:,:) + integer :: ilnlnQ_lo, ilnlnQ_hi, nQ,iylo, iQ, if + integer, save :: warn_id = warn_id_INIT + + if (ubound(val,dim=1) < iflv_max) call wae_error('pdftab_ValTab',& + &'upper bound of val is too low', intval=ubound(val,dim=1)) + + !-- y weights taken care of elsewhere.... + call WgtGridQuant(tab%grid, y, iylo, y_wgts) + !-- Q weights need some help in finding location etc. + lnlnQ = lnln(tab,Q) + + if (tab%freeze_at_Qmin .and. lnlnQ < tab%lnlnQ_min) then + lnlnQ = tab%lnlnQ_min + else if (lnlnQ < (one-warn_tolerance)*tab%lnlnQ_min & + &.or. lnlnQ > (one+warn_tolerance)*tab%lnlnQ_max) then + call wae_warn(default_max_warn, warn_id, & + &'pdftab_ValTab: Q out of range; result set to zero; Q was:',& + &dbleval=Q) + val = zero + return + end if + + call request_iQrange(tab,lnlnQ,tab%lnlnQ_order,ilnlnQ_lo,ilnlnQ_hi,lnlnQ_norm) + nQ = ilnlnQ_hi - ilnlnQ_lo + !OLD lnlnQ_norm = (lnlnQ-tab%lnlnQ_min)/tab%dlnlnQ + !OLD ilnlnQ_lo = floor(lnlnQ_norm) - tab%lnlnQ_order/2 + !OLD ilnlnQ_lo = max(0, min(tab%nQ-tab%lnlnQ_order,ilnlnQ_lo)) + call uniform_interpolation_weights(lnlnQ_norm, lnlnQ_wgts(0:nQ)) + + allocate(wgts(lbound(y_wgts,dim=1):ubound(y_wgts,dim=1),0:nQ)) + do iQ = 0, nQ + wgts(:,iQ) = y_wgts(:) * lnlnQ_wgts(iQ) + end do + + !-- is this order more efficient, or should we not bother to + ! calculate wgts? + do if = iflv_min, iflv_max + val(if) = sum(wgts*tab%tab(iylo:iylo+size(y_wgts)-1,& + & if,ilnlnQ_lo:ilnlnQ_hi)) + end do + !write(0,*) ilnlnQ_lo, ilnlnQ_hi, real(lnlnQ_wgts), val(1) + + deallocate(y_wgts, wgts) + end subroutine pdftab_ValTab_yQ + + + !---------------------------------------------------------------- + !! Returns a vector val(iflv_min:iflv_max) for the PDF at this x,Q. + subroutine pdftab_ValTab_xQ(tab,x,Q,val) + type(pdftab), intent(in) :: tab + real(dp), intent(in) :: x, Q + real(dp), intent(out) :: val(iflv_min:) + call pdftab_ValTab_yQ(tab,-log(x),Q,val) + end subroutine pdftab_ValTab_xQ + + + !----------------------------------------------------------- + !! Deletes all allocated info associated with the tabulation + subroutine pdftab_DelTab_0d(tab) + type(pdftab), intent(inout) :: tab + integer :: i + deallocate(tab%tab) + deallocate(tab%lnlnQ_vals) + if (tab%nf_info_associated) then + deallocate(tab%seginfo) + deallocate(tab%nf_int) + deallocate(tab%as2pi) + end if + if (associated(tab%evops)) then + do i = 0, tab%nQ + call Delete(tab%evops(i)) + end do + !write(0,*) "CURRENTLY UNABLE TO DELETE EVOP CONTENTS" + deallocate(tab%evops) + end if + end subroutine pdftab_DelTab_0d + subroutine pdftab_DelTab_1d(tab) + type(pdftab), intent(inout) :: tab(:) + integer :: i + do i = 1, size(tab) + call pdftab_DelTab_0d(tab(i)) + end do + end subroutine pdftab_DelTab_1d + + + !------------------------------------------------------------------ + !! Given a tab and lnlnQ value, determine the range of iQ entries, + !! iQ_lo:iQ_hi to be used for interpolating the grid. + !! + !! Where possible (i.e. if there are sufficient Q values in the + !! grid) ensure that iQ_hi-iQ_lo = nrequest; for grids with varnf, + !! all iQ_lo:iQ_hi values should correspond to the same nf value. + !! + !! return value of lnlnQ_norm = (lnlnQ - lnlnQ(iQ_lo))/dlnlnQ + !! + subroutine request_iQrange(tab, lnlnQ, nrequest, iQ_lo, iQ_hi, lnlnQ_norm) + type(pdftab), intent(in) :: tab + real(dp), intent(in) :: lnlnQ + integer, intent(in) :: nrequest + integer, intent(out) :: iQ_lo, iQ_hi + real(dp), intent(out) :: lnlnQ_norm + !------------------------------------- + real(dp) :: dist, distclosest + integer :: nfclosest, nflcl + type(pdfseginfo), pointer :: seginfo + if (nrequest < 1) call wae_error('request_iQrange',& + &'nrequest should be >= 1',intval=nrequest) + + if (.not. tab%nf_info_associated) then + lnlnQ_norm = (lnlnQ-tab%lnlnQ_min)/tab%dlnlnQ + iQ_lo = floor(lnlnQ_norm) - nrequest/2 + iQ_lo = max(0, min(tab%nQ-nrequest,iQ_lo)) + iQ_hi = min(tab%nQ,iQ_lo + nrequest) + lnlnQ_norm = lnlnQ_norm - iQ_lo + else + ! need to find range to which we are closest. There is certainly + ! a better way of doing it... + distclosest = 1e10_dp + do nflcl = tab%nflo, tab%nfhi + dist = max(zero,(lnlnQ-tab%seginfo(nflcl)%lnlnQ_hi),& + & (tab%seginfo(nflcl)%lnlnQ_lo-lnlnQ)) + if (dist < distclosest) then + nfclosest = nflcl + distclosest = dist + end if + end do + seginfo => tab%seginfo(nfclosest) + if (seginfo%ilnlnQ_lo == seginfo%ilnlnQ_hi) then + iQ_lo = seginfo%ilnlnQ_lo + iQ_hi = iQ_lo + lnlnQ_norm = zero + else + lnlnQ_norm = (lnlnQ-seginfo%lnlnQ_lo)/seginfo%dlnlnQ & + &+ seginfo%ilnlnQ_lo + !write(0,*) lnlnQ_norm, seginfo%dlnlnQ + iQ_lo = floor(lnlnQ_norm) - nrequest/2 + iQ_lo = max(seginfo%ilnlnQ_lo, min(seginfo%ilnlnQ_hi-nrequest,iQ_lo)) + iQ_hi = min(seginfo%ilnlnQ_hi,iQ_lo + nrequest) + lnlnQ_norm = lnlnQ_norm - iQ_lo + !write(0,*) iQ_lo, iQ_hi, invlnln(tab,lnlnQ), lnlnQ_norm + end if + end if + end subroutine request_iQrange + + + !------------------------------------- + !! conversion from Q to lnlnQ + function lnln(tab,Q) + type(pdftab), intent(in) :: tab + real(dp), intent(in) :: Q + real(dp) :: lnln + + lnln = log(log(Q/tab%lambda_eff)) + end function lnln + + !! conversion from lnlnQ to Q + function invlnln(tab,lnlnQ) + type(pdftab), intent(in) :: tab + real(dp), intent(in) :: lnlnQ + real(dp) :: invlnln + + invlnln = exp(exp(lnlnQ))*tab%lambda_eff + end function invlnln + +!OLD! function lnln_norm(tab,Q) +!OLD! type(pdftab), intent(in) :: tab +!OLD! real(dp), intent(in) :: Q +!OLD! real(dp) :: lnln_norm +!OLD! +!OLD! if (tab%nf_info_associated) call wae_error('lnln_norm') +!OLD! lnln_norm = (lnln(tab,Q) - tab%lnlnQ_min)/tab%dlnlnQ +!OLD! end function lnln_norm +!OLD! +!OLD! function invlnln_norm(tab,lnlnQ_norm) +!OLD! type(pdftab), intent(in) :: tab +!OLD! real(dp), intent(in) :: lnlnQ_norm +!OLD! real(dp) :: invlnln_norm +!OLD! +!OLD! if (tab%nf_info_associated) call wae_error('invlnln_norm') +!OLD! invlnln_norm = invlnln(tab, lnlnQ_norm*tab%dlnlnQ + tab%lnlnQ_min) +!OLD! end function invlnln_norm +end module pdf_tabulate_new diff --git a/src/qcd.f90 b/src/qcd.f90 new file mode 100644 index 0000000..f225850 --- /dev/null +++ b/src/qcd.f90 @@ -0,0 +1,145 @@ +! $Id: qcd.f90,v 1.13 2004/09/18 14:39:29 salam Exp $ +module qcd + use types; use consts_dp + + integer, parameter :: nf_def = 5 + real(dp), parameter :: ca_def = 3, cf_def = four/three, tr_def = half + real(dp), parameter :: tf_def = tr_def * nf_def + + !-- the following are all modifiable, but have default values + real(dp), public :: ca = ca_def + real(dp), public :: cf = cf_def + real(dp), public :: tr = tr_def + + integer, public :: nf_int = nf_def + integer, public :: nf_u = nf_def/2 + integer, public :: nf_d = (nf_def+1)/2 + real(dp), public :: nf = nf_def, tf = tf_def + ! HACK TO GET GLUON + SINGLET EVOLUTION in 0 & 1 + ! For it to work, quark component in 2 must be zero. + !integer, parameter, public :: nf_u = nf_def, nf_d = 0 + + ! beta2 is from Tarasov JINR P2-82-900 (Dubna 1982) + ! Larin NIKHEF-H/92-18 hep-ph/9302240 + real(dp), public :: beta0 = (11*ca_def - four*tf_def)/(12*pi) + real(dp), public :: twopi_beta0 = (11*ca_def - four*tf_def)/6.0_dp + real(dp), public :: beta1 = (17*ca_def**2 - tf_def*(10*ca_def + 6*cf_def))& + & / (24*pisq) + real(dp), public :: beta2 = (2857*ca_def**3 & + & + (54*cf_def**2-615*cf_def*ca_def-1415*ca_def**2)*two*tf_def& + & + (66*cf_def + 79*ca_def)*(two*tf_def)**2)/(3456*pi**3) + + !--- nomenclature is: + ! alpha_s(nf+1,mu) = alpha_s(nf,mu) + + ! sum_{mn} alphastep_mn * (alphas)^(m+1) ln^n(mu^2/m(mu^2)^2) + ! + ! taken from hep-ph/9411260; should also refer to + ! Bernreuther, Wetzel, NPB197 (1982) 228 + ! Bernreuther, Annals of Phys. 151 (1983) 127 + ! + ! Only use this if (mass_steps_on)? + logical, public :: mass_steps_on = .true. + !logical, public, parameter :: mass_steps_on = .false. + !---- the following is for the MSbar mass + ! taken from hep-ph/9411260; should also refer to + ! Bernreuther, Wetzel, NPB197 (1982) 228 + ! Bernreuther, Annals of Phys. 151 (1983) 127 + real(dp), public :: alphastep11 = four*tr_def/(12*pi) + real(dp), public :: alphastep22 = (four*tr_def/(12*pi))**2 + real(dp), public :: alphastep21 = tr_def*(10*ca_def + 6*cf_def)/(24*pisq) + real(dp), public :: alphastep20_msbar=& + &(13.0_dp/48.0_dp*cf_def-two/9.0_dp*ca_def)& + & *tr_def/pisq + !-- for the pole mass, take this from hep-ph/9706430 + ! (Chetyrkin, Kniehl and Steinhauser), PRL 79 (1997) 2184 + ! though it is not the original referece, just a "container" + !-- expression not known for variable colour factors? + ! NB: they express nf-1 in terms of nf... + !real(dp), public :: alphastep20_pole = 11.0_dp/72.0_dp/pisq + !real(dp), public :: alphastep20_pole = 7.0_dp/24.0_dp/pisq + real(dp), public :: alphastep20_pole = & + &(15.0_dp/16.0_dp*cf_def-two/9.0_dp*ca_def) * tr_def/pisq + + real(dp), public :: cmw_K = ca_def*(67.0_dp/18.0_dp - pisq/6.0_dp) & + & - tf_def * 10.0_dp/9.0_dp + + !!!! Taken from Moch, Vermaseren & Vogt: NB TR dependence not in... + real(dp), parameter :: cmw_K2_def = & + & ca_def**2 * ( 245._dp/24._dp - 67._dp/9._dp*zeta2 & + & + 11.0_dp/6._dp * zeta3 + 11.0_dp/5._dp * zeta2**2)& + &+ two*cf_def*tf_def * (-55._dp/24._dp + 2*zeta3)& + &+ two*ca_def*tf_def * (-209._dp/108._dp + 10._dp/9._dp*zeta2 & + & - 7._dp/3._dp * zeta3)& + &- four*tf_def**2 /27._dp + real(dp), public :: cmw_K2 = cmw_K2_def + real(dp), public :: mvv_A3 = 16*cf_def*cmw_K2_def + real(dp), public :: mvv_A3G = 16*ca_def*cmw_K2_def + + + !--- is it useful to have a fake upper entry? + ! put charm quark mass just above sqrt(2) + real(dp), public, parameter :: & + & quark_masses_def(6) = (/1e-10_dp,1e-10_dp,0.15_dp,& + & 1.414213563_dp, 4.5_dp, 175.0_dp/) + + + public :: qcd_SetNf, qcd_SetGroup!, qcd_SetVogtImod + +contains + + !---------------------------------------------------------------------- + subroutine qcd_SetNf(nf_in) + integer :: nf_in + nf_int = nf_in + nf = nf_int + nf_u = nf_int/2 + nf_d = (nf_int+1)/2 + tf = tr * nf + call qcd_set_beta0 + end subroutine qcd_SetNf + + !---------------------------------------------------------------------- + subroutine qcd_SetGroup(ca_in,cf_in,tr_in) + real(dp), intent(in) :: ca_in,cf_in,tr_in + ca = ca_in + cf = cf_in + tr = tr_in + tf = nf * tr + call qcd_set_beta0 + end subroutine qcd_SetGroup + + !---------------------------------------------------------------------- + subroutine qcd_set_beta0 + beta0 = (11*ca - four*tf)/(12*pi) + twopi_beta0 = twopi * beta0 + beta1 = (17*ca**2 - tf*(10*ca + 6*cf)) / (24*pisq) + beta2 = (2857*ca**3 + (54*cf**2-615*CF*CA-1415*ca**2)*two*tf& + & + (66*cf + 79*ca)*(two*tf)**2)/(3456*pi**3) + !-- matching thresholds ----------------- + alphastep11 = four*tr/(12*pi) + alphastep22 = (four*tr/(12*pi))**2 + alphastep21 = tr*(10*ca + 6*cf)/(24*pisq) + alphastep20_msbar = (13.0_dp/48.0_dp*cf-two/9.0_dp*ca)*tr/pisq + ! -11.0_dp/72.0_dp/pisq + !-- expression not know for variable colour factors + !alphastep20_pole = 7.0_dp/24.0_dp/pisq + alphastep20_pole = (15.0_dp/16.0_dp*cf-two/9.0_dp*ca)*tr/pisq + cmw_K = ca*(67.0_dp/18.0_dp - pisq/6.0_dp) - tf*10.0_dp/9.0_dp + cmw_K2 = & + & ca**2 * ( 245._dp/24._dp - 67._dp/9._dp*zeta2 & + & + 11.0_dp/6._dp * zeta3 + 11.0_dp/5._dp * zeta2**2)& + &+ two*cf*tf * (-55._dp/24._dp + 2*zeta3)& + &+ two*ca*tf * (-209._dp/108._dp + 10._dp/9._dp*zeta2 & + & - 7._dp/3._dp * zeta3)& + &- four*tf**2 /27._dp + mvv_A3 = 16*cf*cmw_K2 + mvv_A3G = 16*ca*cmw_K2 + end subroutine qcd_set_beta0 + +!!$ !-------- overkill ---------------------------------------- +!!$ subroutine qcd_SetVogtImod(imod) +!!$ integer, intent(in) :: imod +!!$ vogt_imod = imod +!!$ end subroutine qcd_SetVogtImod + +end module qcd diff --git a/src/qcd_coupling.f90 b/src/qcd_coupling.f90 new file mode 100644 index 0000000..487e3d7 --- /dev/null +++ b/src/qcd_coupling.f90 @@ -0,0 +1,443 @@ +!--------------------------------------------------------------- +!! provides facilities related to alphas calculations +!! +!! there are two ways of accessing it: either with a handle which +!! contains the details of the particular alfas which is being dealt +!! with (e.g. one loop etc...), or without a handle, in which case the +!! global handle is used. +!! +!! Original core based on BRW (analytical NLO running coupling) +!! Tested 25/04/00 +!! +!! Subsequently updated to makes use of the new_as module which implements +!! running coupling via the solution of the QCD differential equation. +!! +!------------------------------------------------------------------- +module qcd_coupling + use new_as; use types; use consts_dp + use warnings_and_errors + implicit none + private + + + type running_coupling + private + type(na_handle) :: nah ! simply "redirect" to new coupling + logical :: use_nah + !-- following components are related to old analytical approximations + real(dp) :: QCDL5 + real(dp) :: BN(3:6), CN(3:6), CN5(3:6) + integer :: nloop, nf + end type running_coupling + public :: running_coupling + + interface InitRunningCoupling + module procedure as_Init_ash, as_Init_noash + end interface + public :: InitRunningCoupling + interface Value + module procedure as_Value_ash, as_Value_noash + end interface + public :: Value + interface Delete + !-- for digital f90 the second one causes problems + module procedure as_Del_ash!, as_Del_noash + end interface + public :: Delete + public :: NfRange, NfAtQ, QRangeAtNf, QuarkMass + interface NumberOfLoops + module procedure NumLoops_in_coupling + end interface + public :: NumberOfLoops + + ! A public instance of the coupling (as far as an outside user is + ! concerned). This is set if the user calls the initialisation + ! routine without providing a "running_coupling" object as an + ! argument. HIGHLY discouraged and may break in the future... + type(running_coupling), target, save :: ash_global + public :: ash_global + + + !--- all constants below relate to the now somewhat obsolete + ! NLO analytical approximation for the running coupling + !----------------------------------------------------------------- + !-- inclusion of CN is a rather tricky way of introducing + ! support for 1 and 2-loops in a fairly similary way + ! and B(3:6) is a way of introducing support for fixed or variable + ! flavour numbers + real(dp), parameter :: rmass(6) = (/0D0,0D0,.15D0,1.7D0,5.3D0,175D0/) + !real(dp), parameter :: rmass(6) = (/0D0,0D0,1D0,1.1D0,1.2D0,2005D0/) + real(dp), parameter :: CAFAC = 3.0_dp, CFFAC = 4.0_dp/3.0_dp + real(dp), parameter :: PIFAC = 3.141592653589793238462643383279502884197_dp + real(dp), parameter :: B3=((11.0_dp*CAFAC)- 6.0_dp)/(12.0_dp*PIFAC) + real(dp), parameter :: B4=((11.0_dp*CAFAC)- 8.0_dp)/(12.0_dp*PIFAC) + real(dp), parameter :: B5=((11.0_dp*CAFAC)-10.0_dp)/(12.0_dp*PIFAC) + real(dp), parameter :: B6=((11.0_dp*CAFAC)-12.0_dp)/(12.0_dp*PIFAC) + !-- with absoft there are some difficulties in accessing this quant + ! from outside + real(dp), parameter, public :: as_BN(3:6) = (/ B3, B4, B5, B6/) + real(dp), parameter :: trueC3=((17.0_dp*CAFAC**2)-(5.0_dp*CAFAC+3.0_dp& + &*CFFAC)*3.0_dp) /(24.0_dp*PIFAC**2)/B3**2 + real(dp), parameter :: trueC4=((17.0_dp*CAFAC**2)-(5.0_dp*CAFAC+3.0_dp& + &*CFFAC)*4.0_dp) /(24.0_dp*PIFAC**2)/B4**2 + real(dp), parameter :: trueC5=((17.0_dp*CAFAC**2)-(5.0_dp*CAFAC+3.0_dp& + &*CFFAC)*5.0_dp) /(24.0_dp*PIFAC**2)/B5**2 + real(dp), parameter :: trueC6=((17.0_dp*CAFAC**2)-(5.0_dp*CAFAC+3.0_dp& + &*CFFAC)*6.0_dp) /(24.0_dp*PIFAC**2)/B6**2 + real(dp), parameter :: as_CN(3:6) = (/ trueC3, trueC4, trueC5, trueC6 /) + + +contains + + !-- alternative versions to allow access to a global alpha + subroutine as_Init_noash(alfas, Q, qcdl5, nloop, fixnf, & + & quark_masses, muMatch_mQuark, use_nah) + real(dp), intent(in), optional :: alfas, Q, qcdl5 + integer, intent(in), optional :: nloop, fixnf + real(dp), intent(in), optional :: quark_masses(4:6) + real(dp), intent(in), optional :: muMatch_mQuark + logical, intent(in), optional :: use_nah + type(running_coupling), pointer :: coupling + coupling => ash_global + call as_Init_ash(coupling, alfas, Q, nloop, fixnf, & + & quark_masses, muMatch_mQuark, use_nah, qcdl5) + end subroutine as_Init_noash + + function as_Value_noash(Q,fixnf) result(Value) + real(dp), intent(in) :: Q + real(dp) :: Value + type(running_coupling), pointer :: coupling + integer, intent(in), optional :: fixnf + coupling => ash_global + Value = as_Value_ash(coupling, Q, fixnf) + end function as_Value_noash + + subroutine as_Del_noash() + type(running_coupling), pointer :: coupling + coupling => ash_global + call as_Del_ash(coupling) + end subroutine as_Del_noash + + + !====================================================================== + ! The following are essentially interface routines to bryan's + ! code for alfas + ! if present alfas then set coupling such alfas at M_Z or Q is equal to alpha_s + ! Alternatively set qcdl5 + ! Can also optionally modify the number of loops and fix the number + ! of flavours + ! + ! As of 30/06/2001, by sepcifying use_nah=.true. it should give + ! fairly transparent access to the differential equation solution + ! for alfas, using new_as. The only proviso is that initialisation + ! may well be quite a bit slower. Also if we want to reinitialise + ! then it is necessary to call Delete + ! + ! As od 16/01/2001 use_nah=.true. will become the default + subroutine as_Init_ash(coupling, alfas, Q, nloop, fixnf, & + & quark_masses, muMatch_mQuark, use_nah, qcdl5) + use assertions + type(running_coupling) :: coupling + real(dp), intent(in), optional :: alfas, Q, qcdl5 + integer, intent(in), optional :: nloop, fixnf + real(dp), intent(in), optional :: quark_masses(4:6) + real(dp), intent(in), optional :: muMatch_mQuark + logical, intent(in), optional :: use_nah + real(dp) :: dummy, lower, upper, middle + real(dp) :: Qloc + real(dp), parameter :: mz = 91.2_dp, eps = 1e-8_dp + + coupling%use_nah = default_or_opt(.true., use_nah) + if (coupling%use_nah) then + call na_Init(coupling%nah, alfas, Q, nloop, fixnf, & + & quark_masses, muMatch_mQuark) + return + else + call wae_error('as_Init_ash','old alphas (analytic approx to solution) is obsolete and will not run...') + end if + + if (present(nloop)) then + coupling%nloop = nloop + else + coupling%nloop = 2 + end if + + !-- a fudge to fix the number of flavours + if (present(fixnf)) then + coupling%BN = as_BN(fixnf) + coupling%CN = as_CN(fixnf) + else + coupling%BN = as_BN + coupling%CN = as_CN + end if + + !-- a fudge to set the number of loops + select case (coupling%nloop) + case(1) + coupling%CN = zero + case(2) + ! keep coupling%CN = as_CN as it was set before + case default + stop 'InitRunningCoupling: nloop must be either 1 or 2' + end select + + if (present(alfas)) then + if (present(Q)) then + Qloc = Q + else + Qloc = mz + end if + !-- set up search limits ---------------------------- + lower = 0.01_dp + upper = 1.0_dp + !-- we may need to revise lower and upper... + do + call priv_as_init_2l(coupling,lower); dummy = Value(coupling,Qloc) + if (dummy > alfas) then + !call hwwarn(100) + upper = lower + lower = lower**2 + cycle + end if + call priv_as_init_2l(coupling,upper); dummy = Value(coupling,Qloc) + if (dummy < alfas) call hwwarn(101) + exit + end do + do + !-- could be more efficient -- but too lazy for now + !write(0,'(4f20.15)') upper, lower, dummy, alfas + middle = sqrt(lower*upper) + call priv_as_init_2l(coupling,middle) + dummy = Value(coupling,Qloc) + if (dummy >= alfas) upper = middle + if (dummy < alfas) lower = middle + if (upper/lower-1.0_dp < eps ) exit + end do + elseif (present(qcdl5)) then + call priv_as_init_2l(coupling,qcdl5) + else + !call priv_as_init_2l(coupling,0.280_dp) ! alfas(91) = 0.124 + call priv_as_init_2l(coupling,0.214_dp) ! alfas(91) = 0.117 + !call priv_as_init_2l(coupling,0.158_dp) ! alfas(91) = 0.112 + end if + end subroutine as_Init_ash + + + !====================================================================== + function as_Value_ash(coupling, Q, fixnf) result(Value) + real(dp), intent(in) :: Q + real(dp) :: Value + type(running_coupling) :: coupling + integer, intent(in), optional :: fixnf + if (coupling%use_nah) then + Value = na_Value(coupling%nah, Q, fixnf) + else + if (present(fixnf)) call wae_error('as_Value_ash: & + &fixnf not support for old alpha_s') + Value = hwualf(coupling, 1, Q) + end if + end function as_Value_ash + + + !====================================================================== + !! Returns the number of loops used for the evolution of this coupling. + integer function NumLoops_in_coupling(coupling) + type(running_coupling) :: coupling + if (coupling%use_nah) then + NumLoops_in_coupling = na_NumberOfLoops(coupling%nah) + else + NumLoops_in_coupling = coupling%nloop + end if + + end function NumLoops_in_coupling + + + !----------------------------------------------------------------- + ! do any required cleaning up + subroutine as_Del_ash(coupling) + type(running_coupling) :: coupling + if (coupling%use_nah) call na_Del(coupling%nah) + end subroutine as_Del_ash + + !----------------------------------------------------------------- + ! Indicate the range of nf values supported by this handle. + subroutine NfRange(coupling, nflo, nfhi) + type(running_coupling), intent(in) :: coupling + integer, intent(out) :: nflo, nfhi + if (coupling%use_nah) then + call na_nfRange(coupling%nah,nflo,nfhi) + else + call wae_Error('NfRange: this routine& + & is only supported with new alpha_s') + end if + end subroutine NfRange + + !------------------------------------------------------------- + ! Returns the number of flavours relevant for scale Q + ! Also returns the range of Qvalues (Qlo, Qhi) for which + ! this value of nf remains the same. + function NfAtQ(coupling, Q, Qlo, Qhi, muM_mQ) + integer :: nfAtQ + type(running_coupling), intent(in) :: coupling + real(dp), intent(in) :: Q + real(dp), intent(out), optional :: Qlo, Qhi + real(dp), intent(in), optional :: muM_mQ + !----------------------------- + if (coupling%use_nah) then + call na_nfAtQ(coupling%nah, Q, nfAtQ, Qlo, Qhi, muM_mQ) + else + call wae_Error('NfAtQ: this routine& + & is only supported with new alpha_s') + end if + end function NfAtQ + + + !====================================================================== + real(dp) function QuarkMass(coupling, iflv) result(mass) + type(running_coupling), intent(in) :: coupling + integer, intent(in) :: iflv + if (coupling%use_nah) then + mass = na_QuarkMass(coupling%nah, iflv) + else + call wae_Error('QuarkMass: this routine& + & is only supported with new alpha_s') + end if + end function QuarkMass + + + + !------------------------------------------------------------- + ! returns the Q range for a given value of nf. If supported. + subroutine QRangeAtNf(coupling, nflcl, Qlo, Qhi, muM_mQ) + type(running_coupling), intent(in) :: coupling + integer, intent(in) :: nflcl + real(dp), intent(out) :: Qlo, Qhi + real(dp), intent(in), optional :: muM_mQ + if (coupling%use_nah) then + call na_QrangeAtNf(coupling%nah, nflcl, Qlo, Qhi, muM_mQ) + else + call wae_Error('QRangeAtNf: this routine& + & is only supported with new alpha_s') + end if + end subroutine QRangeAtNf + + !---------------------------------------------------------------------- + ! the routine that does the real initialisation of alfas + subroutine priv_as_init_2l(coupling, qcdl5) + type(running_coupling) :: coupling + real(dp), intent(in) :: qcdl5 + real(dp) :: dummy + coupling%qcdl5 = qcdl5 + dummy = HWUALF(coupling, 0, 1e2_dp) + end subroutine priv_as_init_2l + !----------------------------------------------------------------------- + ! STRONG COUPLING CONSTANT + ! IOPT == 0 INITIALIZES + ! == 1 TWO-LOOP, FLAVOUR THRESHOLDS + ! + ! BRW routine, with various bits and pieces shuffled around or + ! removed by GPS on 24/04/00 + !--------------------------------------------------------------------- + FUNCTION HWUALF(coupling, IOPT, SCALE) + REAL(DP) :: HWUALF + type(running_coupling), target :: coupling + real(dp), intent(in) :: scale + integer, intent(in) :: iopt + !-------------------------------------------------------------------- + REAL(DP) :: RHO,RAT,RLF + real(dp), pointer :: CN5(:), CN(:), QCDL5, BN(:) + integer :: nf + + CN5 => coupling%CN5 + QCDL5 => coupling%QCDL5 + CN => coupling%CN + BN => coupling%BN + + !-- the rest is init related to this value of lambda5 + IF (IOPT == 0) THEN + !---QCDL5 IS 5-FLAVOUR LAMBDA-MS-BAR + !---COMPUTE THRESHOLD MATCHING + RHO=2.0_dp*LOG(RMASS(6)/QCDL5) + RAT=LOG(RHO)/RHO + CN5(6)=(coupling%BN(5)/(1.0_dp-CN(5)*RAT)-coupling%BN(6)/(1.0_dp-CN(6)*RAT))*RHO + RHO=2.0_dp*LOG(RMASS(5)/QCDL5) + RAT=LOG(RHO)/RHO + CN5(4)=(coupling%BN(5)/(1.0_dp-CN(5)*RAT)-coupling%BN(4)/(1.0_dp-CN(4)*RAT))*RHO + RHO=2.0_dp*LOG(RMASS(4)/QCDL5) + RAT=LOG(RHO)/RHO + CN5(3)=(coupling%BN(4)/(1.0_dp-CN(4)*RAT)-& + & coupling%BN(3)/(1.0_dp-CN(3)*RAT))*RHO+CN5(4) + CN5(5) = zero + ENDIF + IF (SCALE <= QCDL5) then; CALL HWWARN(51); hwualf=0.0_dp; return + end IF + RHO=2.0_dp*LOG(SCALE/QCDL5) + RAT=LOG(RHO)/RHO + !-- this will allow us to fiddle nf later on, according to some + ! flag in coupling + nf = priv_nf(coupling, scale) + RLF = coupling%BN(nf)*RHO/(one - CN(nf)*RAT) + CN5(nf) +!!$ select case(nf) +!!$ case(6) +!!$ RLF=B6*RHO/(1.0_dp-CN(6)*RAT)+CN5(6) +!!$ case(5) +!!$ RLF=B5*RHO/(1.0_dp-CN(5)*RAT) +!!$ case(4) +!!$ RLF=B4*RHO/(1.0_dp-CN(4)*RAT)+CN5(4) +!!$ case default +!!$ RLF=B3*RHO/(1.0_dp-CN(3)*RAT)+CN5(3) +!!$ end select + IF (RLF <= ZERO) then; CALL HWWARN(53); hwualf=0.0_dp; return + end IF + + IF (IOPT == 1) THEN + HWUALF=1.0_dp/RLF + ENDIF + end function hwualf + + !--------------------------------------------------------------- + ! returns the appropriate for the given scale + function priv_nf(coupling, scale) result(nf) + type(running_coupling), intent(in) :: coupling + real(dp), intent(in) :: scale + integer :: nf + IF (SCALE > RMASS(6)) THEN + nf = 6 + ELSEIF (SCALE > RMASS(5)) THEN + nf = 5 + ELSEIF (SCALE > RMASS(4)) THEN + nf = 4 + ELSE + nf = 3 + ENDIF + end function priv_nf + + + !-- a little primitive? -------------------------------------------- + SUBROUTINE HWWARN(ICODE) + integer, intent(in) :: icode + real(dp) :: a, b + write(0,*) ' ALFAS WARNING CODE',ICODE + a = sqrt(0.0_dp) + b = a**2 + !write(0,*) 1.0_dp/(a-b) + stop + END SUBROUTINE HWWARN + + +end module qcd_coupling + +!!$program astest +!!$ use types; use consts_dp +!!$ use qcd_coupling +!!$ implicit none +!!$ integer :: i +!!$ real(dp) :: Q +!!$ +!!$ call InitRunningCoupling(alfas=0.118_dp,nloop=2) +!!$ do i = 0,100 +!!$ Q = 91.2_dp**(i/100.0_dp) +!!$ write(6,*) Q, Value(Q) +!!$ end do +!!$ +!!$end program astest diff --git a/src/random.f90 b/src/random.f90 new file mode 100644 index 0000000..dad02c9 --- /dev/null +++ b/src/random.f90 @@ -0,0 +1,55 @@ +!-------------------------------------------------------------------- +!! contains the random number generator; use l'Ecuyer's method which +!! is sufficient for simple uses (want something that above all is +!! quick) . Original code comes via herwig. +!! +module random + use types + implicit none + private + + public :: ran,rangen, SetSeed, GetSeed + + integer, save :: iseed(2) = (/123450,678900/) +contains + function ran() + real(dp) :: ran + real(dp) :: rann(1) + !call random_number(ran) + call rangen(rann) + ran = rann(1) + end function ran + + subroutine rangen(r) + implicit none + !---random number generator + ! uses method of l'Ecuyer, (via F.James, Comp Phys Comm 60(1990)329) + ! returns the vector r(:) of random values + real(dp), intent(out) :: r(:) + integer i,k,iz + do i=1,size(r) + k=iseed(1)/53668 + iseed(1)=40014*(iseed(1)-k*53668)-k*12211 + if (iseed(1).lt.0) iseed(1)=iseed(1)+2147483563 + k=iseed(2)/52774 + iseed(2)=40692*(iseed(2)-k*52774)-k*3791 + if (iseed(2).lt.0) iseed(2)=iseed(2)+2147483399 + iz=iseed(1)-iseed(2) + if (iz.lt.1) iz=iz+2147483562 + r(i)=real(iz,kind=dp)*4.656613d-10 + enddo + end subroutine rangen + + + subroutine SetSeed(iseed_in) + integer, intent(in) :: iseed_in(2) + iseed = iseed_in + end subroutine SetSeed + + + subroutine GetSeed(iseed_out) + integer, intent(out) :: iseed_out(2) + iseed_out = iseed + end subroutine GetSeed + +end module random diff --git a/src/runge_kutta.f90 b/src/runge_kutta.f90 new file mode 100644 index 0000000..1d232a4 --- /dev/null +++ b/src/runge_kutta.f90 @@ -0,0 +1,99 @@ +! $Id: runge_kutta.f90,v 1.1 2001/06/27 13:40:17 gsalam Exp $ +module runge_kutta + use types; use consts_dp + implicit none + private + + + real(dp), parameter :: third = one/three + + interface rkstp + module procedure rkstp_0d, rkstp_1d, rkstp_2d + end interface + public :: rkstp + + +contains + !---------------------------------------------------------------------- + ! write the Runge Kutta routine; try and be efficient with work-space + ! This is a scalar version... + subroutine rkstp_0d(h,x,y,conv) + real(dp), intent(in) :: h + real(dp), intent(inout) :: x, y + interface + subroutine conv(x,y,dy) + use types + real(dp), intent(in) :: x, y + real(dp), intent(out) :: dy + end subroutine conv + end interface + !------------------------------------------------------------ + real(dp) :: w1, w2, w3 + real(dp) :: hh + hh = half * h + call conv(x,y,w1); w1 = w1 * hh ! w1 = k1/2 + call conv(x+hh, y + w1, w2); w2 = w2 * hh ! w2 = k2/2 + call conv(x+hh, y + w2, w3); w3 = w3 * h ! w3 = k3 + w2 = w1 + two*w2 ! w2 = half*k1 + k2 + call conv(x+h , y + w3, w1); w1 = w1 * hh ! w1 = k4/2 + + x = x + h + ! k1/2 + k2 + k3 + k4/2 + y = y + third * (w2 + w3 + w1) + end subroutine rkstp_0d + + !---------------------------------------------------------------------- + subroutine rkstp_1d(h,x,y,conv) + real(dp), intent(in) :: h + real(dp), intent(inout) :: x, y(:) + interface + subroutine conv(x,y,dy) + use types + real(dp), intent(in) :: x, y(:) + real(dp), intent(out) :: dy(:) + end subroutine conv + end interface + !------------------------------------------------------------ + real(dp) :: w1(size(y)), w2(size(y)), w3(size(y)) + real(dp) :: hh + hh = half * h + call conv(x,y,w1); w1 = w1 * hh ! w1 = k1/2 + call conv(x+hh, y + w1, w2); w2 = w2 * hh ! w2 = k2/2 + call conv(x+hh, y + w2, w3); w3 = w3 * h ! w3 = k3 + w2 = w1 + two*w2 ! w2 = half*k1 + k2 + call conv(x+h , y + w3, w1); w1 = w1 * hh ! w1 = k4/2 + + x = x + h + ! k1/2 + k2 + k3 + k4/2 + y = y + third * (w2 + w3 + w1) + end subroutine rkstp_1d + + !---------------------------------------------------------------------- + subroutine rkstp_2d(h,x,y,conv) + real(dp), intent(in) :: h + real(dp), intent(inout) :: x, y(:,:) + interface + subroutine conv(x,y,dy) + use types + real(dp), intent(in) :: x, y(:,:) + real(dp), intent(out) :: dy(:,:) + end subroutine conv + end interface + !------------------------------------------------------------ + real(dp) :: w1(size(y,dim=1),size(y,dim=2)), & + & w2(size(y,dim=1),size(y,dim=2)), & + & w3(size(y,dim=1),size(y,dim=2)) + real(dp) :: hh + hh = half * h + call conv(x,y,w1); w1 = w1 * hh ! w1 = k1/2 + call conv(x+hh, y + w1, w2); w2 = w2 * hh ! w2 = k2/2 + call conv(x+hh, y + w2, w3); w3 = w3 * h ! w3 = k3 + w2 = w1 + two*w2 ! w2 = half*k1 + k2 + call conv(x+h , y + w3, w1); w1 = w1 * hh ! w1 = k4/2 + + x = x + h + ! k1/2 + k2 + k3 + k4/2 + y = y + third * (w2 + w3 + w1) + end subroutine rkstp_2d + +end module runge_kutta diff --git a/src/sort.f90 b/src/sort.f90 new file mode 100644 index 0000000..db6314a --- /dev/null +++ b/src/sort.f90 @@ -0,0 +1,258 @@ +!! A module that provides access to a quicksort form of sorting +!! routine. +!! +!! Not clear that it is very efficient (e.g. compared to C++ stdlib +!! sort). It is based on the ideas behind NR indexx, but has been +!! rewritten (without looking at the NR f90 code) to avoid copyright +!! issues. Considerable tests have been performed [but no guarantees +!! are provided...!] +!! +module sort + use types + use warnings_and_errors + use assertions + implicit none + private + + + + interface indexx + module procedure indexx_dp, indexx_int + end interface + public :: indexx + + interface swap + module procedure swap_int, swap_dp + end interface + + +contains + + !------------------------------------------------------------------------- + !! A non-recursive version of the quick sort algorithm. It returns + !! an array idx such that array(idx) is sorted. + !! + !! Following NR outline, it uses insertion for for sorting small + !! sub-segments, sentinels to reduce the number of checks when + !! pivoting and median of first, middle and last elements in order + !! to select the pivot, to reduce the chances of the worst case + !! (N^2) occurring. + !! + !! Note it uses a fixed-size stack, which is not so great an idea... + !! (recursion would have had the advantage that this would not have + !! been a problem). + subroutine indexx_dp(array,idx) + real(dp), intent(in) :: array(:) + integer, intent(out) :: idx(size(array)) + !---------------------------------- + integer, parameter :: insertion_threshold = 7, stack_size = 50 + type lrpair + integer :: l, r + end type lrpair + type(lrpair) :: stack(stack_size) + integer :: nmid, i, j, l, r, ixstack, medidx, n + real(dp) :: medval + + !n = size(array) + !if (n/=size(idx)) stop 'array and idx are different sizes' + n = assert_eq(size(idx),size(array),'indexx_dp') + + forall(i=1:n) idx(i) = i + + ! push the whole array section onto the stack + ixstack = 1 + stack(1) = lrpair(1,n); ixstack = 1 + do + ! pull an array section off the stack + l = stack(ixstack)%l + r = stack(ixstack)%r + ixstack = ixstack - 1 + ! get to work on it + if (r-l < insertion_threshold) then + ! run an inlined insertion sort. + do i = l+1, r + medidx = idx(i) + medval = array(medidx) + ! look for the place where we should insert the element "medval", + ! and as we go about it, shift the other elements up by one + do j = i-1, l, -1 + if (medval < array(idx(j))) then + idx(j+1) = idx(j) + else + exit + end if + end do + ! insert medval in its correct location + idx(j+1) = medidx + end do + else + ! NR idea is to take the median value of first, middle and + ! last elements, so do a little insertion sort to get these + ! three elements into order + nmid = (l+r)/2 + ! first place the middle element in position l+1 + call swap(idx(l+1),idx(nmid)) + if (array(idx(l+1)) < array(idx(l)) ) call swap(idx(l+1),idx(l)) + if (array(idx(r)) < array(idx(l+1))) then + call swap(idx(r),idx(l+1)) + if (array(idx(l+1)) < array(idx(l))) call swap(idx(l+1),idx(l)) + end if + medidx = idx(l+1) + medval = array(medidx) + + ! Then run up from first (non-trivial) element, and down from last + ! element, swapping things as need be until i and j cross + i = l+1; j = r + do + do + i = i + 1 + if (array(idx(i)) >= medval) exit + end do + do + j = j - 1 + if (array(idx(j)) <= medval) exit + end do + if (i > j) exit + call swap(idx(i), idx(j)) + end do + ! now insert medval (the partitioning element) into the + ! correct position + idx(l+1) = idx(j) + idx(j) = medidx + + ! now put things onto the stack + if (ixstack+2 > stack_size) stop 'stack too small' + stack(ixstack+1) = lrpair(l,j-1) + stack(ixstack+2) = lrpair(j,r) + ixstack = ixstack + 2 + end if + + if (ixstack == 0) exit + end do + + end subroutine indexx_dp + + + + !------------------------------------------------------------------------- + !! A non-recursive version of the quick sort algorithm. It returns + !! an array idx such that array(idx) is sorted. + !! + !! Following NR outline, it uses insertion for for sorting small + !! sub-segments, sentinels to reduce the number of checks when + !! pivoting and median of first, middle and last elements in order + !! to select the pivot, to reduce the chances of the worst case + !! (N^2) occurring. + !! + !! Note it uses a fixed-size stack, which is not so great an idea... + !! (recursion would have had the advantage that this would not have + !! been a problem). + subroutine indexx_int(array,idx) + integer, intent(in) :: array(:) + integer, intent(out) :: idx(size(array)) + !---------------------------------- + integer, parameter :: insertion_threshold = 7, stack_size = 50 + type lrpair + integer :: l, r + end type lrpair + type(lrpair) :: stack(stack_size) + integer :: nmid, i, j, l, r, ixstack, medidx, n + real :: medval + + !n = size(array) + !if (n/=size(idx)) stop 'array and idx are different sizes' + n = assert_eq(size(idx),size(array),'indexx_dp') + + forall(i=1:n) idx(i) = i + + ! push the whole array section onto the stack + ixstack = 1 + stack(1) = lrpair(1,n); ixstack = 1 + do + ! pull an array section off the stack + l = stack(ixstack)%l + r = stack(ixstack)%r + ixstack = ixstack - 1 + ! get to work on it + if (r-l < insertion_threshold) then + ! run an inlined insertion sort. + do i = l+1, r + medidx = idx(i) + medval = array(medidx) + ! look for the place where we should insert the element "medval", + ! and as we go about it, shift the other elements up by one + do j = i-1, l, -1 + if (medval < array(idx(j))) then + idx(j+1) = idx(j) + else + exit + end if + end do + ! insert medval in its correct location + idx(j+1) = medidx + end do + else + ! NR idea is to take the median value of first, middle and + ! last elements, so do a little insertion sort to get these + ! three elements into order + nmid = (l+r)/2 + ! first place the middle element in position l+1 + call swap(idx(l+1),idx(nmid)) + if (array(idx(l+1)) < array(idx(l)) ) call swap(idx(l+1),idx(l)) + if (array(idx(r)) < array(idx(l+1))) then + call swap(idx(r),idx(l+1)) + if (array(idx(l+1)) < array(idx(l))) call swap(idx(l+1),idx(l)) + end if + medidx = idx(l+1) + medval = array(medidx) + + ! Then run up from first (non-trivial) element, and down from last + ! element, swapping things as need be until i and j cross + i = l+1; j = r + do + do + i = i + 1 + if (array(idx(i)) >= medval) exit + end do + do + j = j - 1 + if (array(idx(j)) <= medval) exit + end do + if (i > j) exit + call swap(idx(i), idx(j)) + end do + ! now insert medval (the partitioning element) into the + ! correct position + idx(l+1) = idx(j) + idx(j) = medidx + + ! now put things onto the stack + if (ixstack+2 > stack_size) stop 'stack too small' + stack(ixstack+1) = lrpair(l,j-1) + stack(ixstack+2) = lrpair(j,r) + ixstack = ixstack + 2 + end if + + if (ixstack == 0) exit + end do + + end subroutine indexx_int + + + subroutine swap_dp(a,b) + real, intent(inout) :: a,b + real :: dummy + dummy=a + a=b + b=dummy + end subroutine swap_dp + + subroutine swap_int(a,b) + integer, intent(inout) :: a,b + integer :: dummy + dummy=a + a=b + b=dummy + end subroutine swap_int + +end module sort diff --git a/src/special_functions.f90 b/src/special_functions.f90 new file mode 100644 index 0000000..5ee2807 --- /dev/null +++ b/src/special_functions.f90 @@ -0,0 +1,1055 @@ +!====================================================================== +! A collection of special functions -- currently taken from CERNLIB (GPL +! with restriction that military use is forbidden). Collection curently +! very limited. +! +! Does not follow the coding conventions set out for the disresum package. +! +! $Id: special_functions.f90,v 1.2 2004/09/21 18:50:24 salam Exp $ +module special_functions + private + + public :: ddilog, dpsipg, dgamma + public :: wgplg !NEW: TO BE TESTED + + + !-------------------------------------------- + ! want them accessible with simpler names? + interface gamma + module procedure dgamma + end interface + interface dilog + module procedure ddilog + end interface + public :: dilog, gamma + public :: psi + + +contains + + + !---------------------------------------------------------------------- + ! Will need it often + function psi(x,k) + use types + implicit none + real(dp) :: psi + real(dp), intent(in) :: x + integer, intent(in), optional :: k + !---------------------------------------------------------------------- + integer :: k_local + if (present(k)) then + k_local = k + else + k_local = 0 + end if + psi = dpsipg(x,k_local) + end function psi + + + + +!====================================================================== +! BELOW: the cernlib codes converted to f90 +!====================================================================== + + !-- DDILOG aka C332 ------------------------------------- + FUNCTION DDILOG(X) +! 1 "gen/imp64.inc" 1 +! +! imp64.inc +! + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +! 12 "dilog64.F" 2 + + DIMENSION C(0:19) + + PARAMETER (Z1 = 1, HF = Z1/2) + PARAMETER (PI = 3.14159265358979324D0) + PARAMETER (PI3 = PI**2/3, PI6 = PI**2/6, PI12 = PI**2/12) + + DATA C( 0) / 0.4299669356813697D0/ + DATA C( 1) / 0.4097598753077105D0/ + DATA C( 2) /-0.0185884366014592D0/ + DATA C( 3) / 0.0014575108062268D0/ + DATA C( 4) /-0.0001430418442340D0/ + DATA C( 5) / 0.0000158841541880D0/ + DATA C( 6) /-0.0000019078959387D0/ + DATA C( 7) / 0.0000002419180854D0/ + DATA C( 8) /-0.0000000319341274D0/ + DATA C( 9) / 0.0000000043545063D0/ + DATA C(10) /-0.0000000006578480D0/ + DATA C(11) / 0.0000000000612098D0/ + DATA C(12) /-0.0000000000244332D0/ + DATA C(13) / 0.0000000000182256D0/ + DATA C(14) /-0.0000000000027007D0/ + DATA C(15) / 0.0000000000004042D0/ + DATA C(16) /-0.0000000000000610D0/ + DATA C(17) / 0.0000000000000093D0/ + DATA C(18) /-0.0000000000000014D0/ + DATA C(19) /+0.0000000000000002D0/ + + IF(X .EQ. 1) THEN + H=PI6 + ELSEIF(X .EQ. -1) THEN + H=-PI12 + ELSE + T=-X + IF(T .LE. -2) THEN + Y=-1/(1+T) + S=1 + A=-PI3+HF*(LOG(-T)**2-LOG(1+1/T)**2) + ELSEIF(T .LT. -1) THEN + Y=-1-T + S=-1 + A=LOG(-T) + A=-PI6+A*(A+LOG(1+1/T)) + ELSE IF(T .LE. -HF) THEN + Y=-(1+T)/T + S=1 + A=LOG(-T) + A=-PI6+A*(-HF*A+LOG(1+T)) + ELSE IF(T .LT. 0) THEN + Y=-T/(1+T) + S=-1 + A=HF*LOG(1+T)**2 + ELSE IF(T .LE. 1) THEN + Y=T + S=1 + A=0 + ELSE + Y=1/T + S=-1 + A=PI6+HF*LOG(T)**2 + ENDIF + H=Y+Y-1 + ALFA=H+H + B1=0 + B2=0 + DO I = 19,0,-1 + B0=C(I)+ALFA*B1-B2 + B2=B1 + B1=B0 + END DO + H=-(S*(B0-H*B2)+A) + ENDIF + + DDILOG=H + RETURN + END FUNCTION DDILOG + + +!====================================================================== +! $Id: special_functions.f90,v 1.2 2004/09/21 18:50:24 salam Exp $ +! +! $Log: special_functions.f90,v $ +! Revision 1.2 2004/09/21 18:50:24 salam +! Various speed improvements in evaluation of grid quantities; added WGPLG to special functions -- no longer need CERNLIB linkage +! +! Revision 1.1 2001/06/27 13:40:17 gsalam +! Imported files from release-H1-1-0-7 (soon to become 1-0-8) of the disresum package +! +! Revision 1.4 2001/04/20 14:39:03 salam +! removed Id and Log entries from special functions +! +! Revision 1.3 2001/04/20 14:07:29 salam +! added new documentation figure +! +! Revision 1.2 2001/04/20 09:48:56 salam +! Added some Id keywords to files +! +! Revision 1.1 2001/04/19 15:09:16 salam +! imported all the basic files I hope! +! +! Revision 1.1.1.1 1996/04/01 15:01:54 mclareni +! Mathlib gen +! +! + FUNCTION DGAMMA(X) +! +! +! +! imp64.inc +! + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +! + CHARACTER*(*) NAME + PARAMETER(NAME='GAMMA/DGAMMA') +! + CHARACTER*80 ERRTXT + + DIMENSION C(0:15) + + DATA C( 0) /3.65738772508338244D0/ + DATA C( 1) /1.95754345666126827D0/ + DATA C( 2) /0.33829711382616039D0/ + DATA C( 3) /0.04208951276557549D0/ + DATA C( 4) /0.00428765048212909D0/ + DATA C( 5) /0.00036521216929462D0/ + DATA C( 6) /0.00002740064222642D0/ + DATA C( 7) /0.00000181240233365D0/ + DATA C( 8) /0.00000010965775866D0/ + DATA C( 9) /0.00000000598718405D0/ + DATA C(10) /0.00000000030769081D0/ + DATA C(11) /0.00000000001431793D0/ + DATA C(12) /0.00000000000065109D0/ + DATA C(13) /0.00000000000002596D0/ + DATA C(14) /0.00000000000000111D0/ + DATA C(15) /0.00000000000000004D0/ + + U=X + IF(U .LE. 0) THEN + WRITE(ERRTXT,101) U + CALL MTLPRT(NAME,'C302.1',ERRTXT) + H=0 + GO TO 9 + ENDIF + 8 F=1 + IF(U .LT. 3) THEN + DO 1 I = 1,INT(4-U) + F=F/U + 1 U=U+1 + ELSE + DO 2 I = 1,INT(U-3) + U=U-1 + 2 F=F*U + END IF + H=U+U-7 + ALFA=H+H + B1=0 + B2=0 + DO 3 I = 15,0,-1 + B0=C(I)+ALFA*B1-B2 + B2=B1 + 3 B1=B0 + + 9 DGAMMA=F*(B0-H*B2) + + RETURN + 101 FORMAT('ARGUMENT IS NEGATIVE = ',1P,E15.1) + END FUNCTION DGAMMA + + +!====================================================================== +! + FUNCTION dpsipg(X,K) +! +! +! $Id: special_functions.f90,v 1.2 2004/09/21 18:50:24 salam Exp $ +! +! $Log: special_functions.f90,v $ +! Revision 1.2 2004/09/21 18:50:24 salam +! Various speed improvements in evaluation of grid quantities; added WGPLG to special functions -- no longer need CERNLIB linkage +! +! Revision 1.1 2001/06/27 13:40:17 gsalam +! Imported files from release-H1-1-0-7 (soon to become 1-0-8) of the disresum package +! +! Revision 1.4 2001/04/20 14:39:03 salam +! removed Id and Log entries from special functions +! +! Revision 1.3 2001/04/20 14:07:29 salam +! added new documentation figure +! +! Revision 1.2 2001/04/20 09:48:56 salam +! Added some Id keywords to files +! +! Revision 1.1 2001/04/19 15:09:16 salam +! imported all the basic files I hope! +! +! Revision 1.1.1.1 1996/04/01 15:02:59 mclareni +! Mathlib gen +! +! +! imp64.inc +! + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +! + CHARACTER*(*) NAME + PARAMETER(NAME='RPSIPG/dpsipg') +! + DIMENSION B(0:20,6),C(7,6),NB(6),P1(0:7),Q1(0:7),P2(0:4),Q2(0:4) + DIMENSION SGN(6),SGF(0:6),SGH(6) + + PARAMETER (DELTA = 1D-13) + PARAMETER (Z1 = 1, HF = Z1/2) + PARAMETER (PI = 3.14159265358979324D0) + PARAMETER (C1 = -PI**2, C2 = 2*PI**3, C3 = 2*PI**4) + PARAMETER (C4 = -8*PI**5, C5 = -8*PI**6, C6 = 16*PI**7) + + CHARACTER*80 ERRTXT + + DATA NB /16,17,17,18,19,20/ + DATA SGN /-1,1,-1,1,-1,1/, SGF /1,-1,2,-6,24,-120,720/ + DATA SGH /-0.5D0,1,-3,12,-60,360/ + DATA X0 /1.46163214496836234D0/ + + DATA (P1(J),Q1(J),J=0,7) & + &/ 1.35249996677263464D+4, 6.93891117537634444D-7, & + & 4.52856016995472897D+4, 1.97685742630467364D+4, & + & 4.51351684697366626D+4, 4.12551608353538323D+4, & + & 1.85290118185826102D+4, 2.93902871199326819D+4, & + & 3.32915251494069355D+3, 9.08196660748551703D+3, & + & 2.40680324743572018D+2, 1.24474777856708560D+3, & + & 5.15778920001390847D+0, 6.74291295163785938D+1, & + & 6.22835069189847458D-3, 1/ + + DATA (P2(J),Q2(J),J=0,4) & + &/-2.72817575131529678D-15,7.77788548522961604D+0, & + & -6.48157123766196510D-1, 5.46117738103215070D+1, & + & -4.48616543918019358D+0, 8.92920700481861370D+1, & + & -7.01677227766758664D+0, 3.22703493791143361D+1, & + & -2.12940445131010517D+0, 1/ + + DATA B( 0,1) / 0.334838697910949386D0/ + DATA B( 1,1) /-0.055187482048730095D0/ + DATA B( 2,1) / 0.004510190736011502D0/ + DATA B( 3,1) /-0.000365705888303721D0/ + DATA B( 4,1) / 0.000029434627468223D0/ + DATA B( 5,1) /-0.000002352776815151D0/ + DATA B( 6,1) / 0.000000186853176633D0/ + DATA B( 7,1) /-0.000000014750720184D0/ + DATA B( 8,1) / 0.000000001157993337D0/ + DATA B( 9,1) /-0.000000000090439179D0/ + DATA B(10,1) / 0.000000000007029627D0/ + DATA B(11,1) /-0.000000000000543989D0/ + DATA B(12,1) / 0.000000000000041925D0/ + DATA B(13,1) /-0.000000000000003219D0/ + DATA B(14,1) / 0.000000000000000246D0/ + DATA B(15,1) /-0.000000000000000019D0/ + DATA B(16,1) / 0.000000000000000001D0/ + + DATA B( 0,2) /-0.112592935345473830D0/ + DATA B( 1,2) / 0.036557001742820941D0/ + DATA B( 2,2) /-0.004435942496027282D0/ + DATA B( 3,2) / 0.000475475854728926D0/ + DATA B( 4,2) /-0.000047471836382632D0/ + DATA B( 5,2) / 0.000004521815237353D0/ + DATA B( 6,2) /-0.000000416300079620D0/ + DATA B( 7,2) / 0.000000037338998165D0/ + DATA B( 8,2) /-0.000000003279914474D0/ + DATA B( 9,2) / 0.000000000283211377D0/ + DATA B(10,2) /-0.000000000024104028D0/ + DATA B(11,2) / 0.000000000002026297D0/ + DATA B(12,2) /-0.000000000000168524D0/ + DATA B(13,2) / 0.000000000000013885D0/ + DATA B(14,2) /-0.000000000000001135D0/ + DATA B(15,2) / 0.000000000000000092D0/ + DATA B(16,2) /-0.000000000000000007D0/ + DATA B(17,2) / 0.000000000000000001D0/ + + DATA B( 0,3) / 0.076012604655110384D0/ + DATA B( 1,3) /-0.036257186481828739D0/ + DATA B( 2,3) / 0.005797202338937002D0/ + DATA B( 3,3) /-0.000769646513610481D0/ + DATA B( 4,3) / 0.000091492082189884D0/ + DATA B( 5,3) /-0.000010097131488364D0/ + DATA B( 6,3) / 0.000001055777442831D0/ + DATA B( 7,3) /-0.000000105929577481D0/ + DATA B( 8,3) / 0.000000010285494201D0/ + DATA B( 9,3) /-0.000000000972314310D0/ + DATA B(10,3) / 0.000000000089884635D0/ + DATA B(11,3) /-0.000000000008153171D0/ + DATA B(12,3) / 0.000000000000727572D0/ + DATA B(13,3) /-0.000000000000064010D0/ + DATA B(14,3) / 0.000000000000005562D0/ + DATA B(15,3) /-0.000000000000000478D0/ + DATA B(16,3) / 0.000000000000000041D0/ + DATA B(17,3) /-0.000000000000000003D0/ + + DATA B( 0,4) /-0.077234724056994793D0/ + DATA B( 1,4) / 0.047867163451599467D0/ + DATA B( 2,4) /-0.009440702186674632D0/ + DATA B( 3,4) / 0.001489544740103448D0/ + DATA B( 4,4) /-0.000204944023348860D0/ + DATA B( 5,4) / 0.000025671425065297D0/ + DATA B( 6,4) /-0.000003001393581584D0/ + DATA B( 7,4) / 0.000000332766437356D0/ + DATA B( 8,4) /-0.000000035365412111D0/ + DATA B( 9,4) / 0.000000003630622927D0/ + DATA B(10,4) /-0.000000000362096951D0/ + DATA B(11,4) / 0.000000000035237509D0/ + DATA B(12,4) /-0.000000000003357440D0/ + DATA B(13,4) / 0.000000000000314068D0/ + DATA B(14,4) /-0.000000000000028908D0/ + DATA B(15,4) / 0.000000000000002623D0/ + DATA B(16,4) /-0.000000000000000235D0/ + DATA B(17,4) / 0.000000000000000021D0/ + DATA B(18,4) /-0.000000000000000002D0/ + + DATA B( 0,5) / 0.104933034459278632D0/ + DATA B( 1,5) /-0.078877901652793557D0/ + DATA B( 2,5) / 0.018397415112159397D0/ + DATA B( 3,5) /-0.003352284159396504D0/ + DATA B( 4,5) / 0.000522878230918016D0/ + DATA B( 5,5) /-0.000073179785814740D0/ + DATA B( 6,5) / 0.000009449729612085D0/ + DATA B( 7,5) /-0.000001146339856723D0/ + DATA B( 8,5) / 0.000000132269366108D0/ + DATA B( 9,5) /-0.000000014646669180D0/ + DATA B(10,5) / 0.000000001566940742D0/ + DATA B(11,5) /-0.000000000162791157D0/ + DATA B(12,5) / 0.000000000016490345D0/ + DATA B(13,5) /-0.000000000001634028D0/ + DATA B(14,5) / 0.000000000000158807D0/ + DATA B(15,5) /-0.000000000000015171D0/ + DATA B(16,5) / 0.000000000000001427D0/ + DATA B(17,5) /-0.000000000000000132D0/ + DATA B(18,5) / 0.000000000000000012D0/ + DATA B(19,5) /-0.000000000000000001D0/ + + DATA B( 0,6) /-0.178617622142502753D0/ + DATA B( 1,6) / 0.155776462200520579D0/ + DATA B( 2,6) /-0.041723637673831277D0/ + DATA B( 3,6) / 0.008597141303245400D0/ + DATA B( 4,6) /-0.001496227761073229D0/ + DATA B( 5,6) / 0.000231089608557137D0/ + DATA B( 6,6) /-0.000032632044778436D0/ + DATA B( 7,6) / 0.000004296097867090D0/ + DATA B( 8,6) /-0.000000534528790204D0/ + DATA B( 9,6) / 0.000000063478151644D0/ + DATA B(10,6) /-0.000000007248699714D0/ + DATA B(11,6) / 0.000000000800521979D0/ + DATA B(12,6) /-0.000000000085888793D0/ + DATA B(13,6) / 0.000000000008985442D0/ + DATA B(14,6) /-0.000000000000919356D0/ + DATA B(15,6) / 0.000000000000092225D0/ + DATA B(16,6) /-0.000000000000009090D0/ + DATA B(17,6) / 0.000000000000000882D0/ + DATA B(18,6) /-0.000000000000000084D0/ + DATA B(19,6) / 0.000000000000000008D0/ + DATA B(20,6) /-0.000000000000000001D0/ + + DATA C(1,1) / 1.66666666666666667D-1/ + DATA C(2,1) /-3.33333333333333333D-2/ + DATA C(3,1) / 2.38095238095238095D-2/ + DATA C(4,1) /-3.33333333333333333D-2/ + DATA C(5,1) / 7.57575757575757576D-2/ + DATA C(6,1) /-2.53113553113553114D-1/ + DATA C(7,1) / 1.16666666666666667D0/ + + DATA C(1,2) / 5.00000000000000000D-1/ + DATA C(2,2) /-1.66666666666666667D-1/ + DATA C(3,2) / 1.66666666666666667D-1/ + DATA C(4,2) /-3.00000000000000000D-1/ + DATA C(5,2) / 8.33333333333333333D-1/ + DATA C(6,2) /-3.29047619047619048D0/ + DATA C(7,2) / 1.75000000000000000D1/ + + DATA C(1,3) / 2.00000000000000000D0/ + DATA C(2,3) /-1.00000000000000000D0/ + DATA C(3,3) / 1.33333333333333333D0/ + DATA C(4,3) /-3.00000000000000000D0/ + DATA C(5,3) / 1.00000000000000000D+1/ + DATA C(6,3) /-4.60666666666666667D+1/ + DATA C(7,3) / 2.80000000000000000D+2/ + + DATA (C(J,4),J=1,7) /10,-7,12,-33,130,-691,4760/ + DATA (C(J,5),J=1,7) /60,-56,120,-396,1820,-11056,85680/ + DATA (C(J,6),J=1,7) /420,-504,1320,-5148,27300,-187952,1627920/ + + A=ABS(X) + V=A + IX=X-DELTA + IF(K .LT. 0 .OR. K .GT. 6) THEN + H=0 + WRITE(ERRTXT,101) K + CALL MTLPRT(NAME,'C316.1',ERRTXT) + ELSEIF(ABS(IX-X) .LE. DELTA) THEN + H=0 + WRITE(ERRTXT,102) X + CALL MTLPRT(NAME,'C316.2',ERRTXT) + ELSEIF(K .EQ. 0) THEN + IF(A .LE. 3) THEN + S=0 + IF(A .LT. HF) THEN + S=1/V + V=V+1 + ENDIF + AP=P1(7) + AQ=Q1(7) + DO 11 I = 6,0,-1 + AP=P1(I)+V*AP + 11 AQ=Q1(I)+V*AQ + H=(V-X0)*AP/AQ-S + ELSE + R=1/V**2 + AP=P2(4) + AQ=Q2(4) + DO 12 I = 3,0,-1 + AP=P2(I)+R*AP + 12 AQ=Q2(I)+R*AQ + H=LOG(V)-HF/V+AP/AQ + ENDIF + IF(X .LT. 0) H=H+1/A+PI/TAN(PI*A) + ELSE + K1=K+1 + IF(A .LE. 10) THEN + IF(A .LT. 3) THEN + S=-1/V**K1 + DO 1 J = 1,2-INT(A) + V=V+1 + 1 S=S-1/V**K1 + V=V+1 + ELSEIF(A .LE. 4) THEN + S=0 + ELSE + V=V-1 + S=1/V**K1 + DO 5 J = 1,INT(A)-4 + V=V-1 + 5 S=S+1/V**K1 + ENDIF + H=2*V-7 + ALFA=H+H + B1=0 + B2=0 + DO 2 J = NB(K),0,-1 + B0=B(J,K)+ALFA*B1-B2 + B2=B1 + 2 B1=B0 + H=B0-H*B2+SGF(K)*S + ELSE + S=0 + IF(A .LT. 15) THEN + S=1/V**K1 + DO 3 J = 1,14-INT(A) + V=V+1 + 3 S=S+1/V**K1 + V=V+1 + ENDIF + R=1/V**2 + P=R*C(7,K) + DO 4 J = 6,1,-1 + 4 P=R*(C(J,K)+P) + H=((SGF(K-1)-SGN(K)*P)*V-SGH(K))/V**K1-SGF(K)*S + ENDIF + IF(X .LT. 0) THEN + P=PI*A + IF(K .EQ. 1) THEN + V=C1/SIN(P)**2 + ELSEIF(K .EQ. 2) THEN + V=C2*COS(P)/SIN(P)**3 + ELSEIF(K .EQ. 3) THEN + S=SIN(P)**2 + V=C3*(2*S-3)/S**2 + ELSEIF(K .EQ. 4) THEN + S=SIN(P) + V=C4*COS(P)*(S**2-3)/S**5 + ELSEIF(K .EQ. 5) THEN + S=SIN(P)**2 + V=C5*(15-15*S+2*S**2)/S**3 + ELSEIF(K .EQ. 6) THEN + S=SIN(P) + V=C6*COS(P)*(45-30*S**2+2*S**4)/S**7 + ENDIF + H=SGN(K)*(H+V+SGF(K)/A**K1) + ENDIF + ENDIF + + dpsipg=H + + RETURN + 101 FORMAT('K = ',I5,' (< 0 OR > 6)') + 102 FORMAT('ARGUMENT EQUALS NON-POSITIVE INTEGER =',1P,E15.6) + END function dpsipg + +!====================================================================== +!# 1 "cgplg64.F" +!# 1 "" +!# 1 "" +!# 1 "cgplg64.F" +! +! $Id: special_functions.f90,v 1.2 2004/09/21 18:50:24 salam Exp $ +! +! $Log: special_functions.f90,v $ +! Revision 1.2 2004/09/21 18:50:24 salam +! Various speed improvements in evaluation of grid quantities; added WGPLG to special functions -- no longer need CERNLIB linkage +! +! Revision 1.1.1.1 1996/04/01 15:02:01 mclareni +! Mathlib gen +! +! +!# 1 "gen/pilot.h" 1 +!# 10 "cgplg64.F" 2 + + FUNCTION WGPLG(N,M,X) +!# 1 "gen/imp64.inc" 1 +! +! $Id: special_functions.f90,v 1.2 2004/09/21 18:50:24 salam Exp $ +! +! $Log: special_functions.f90,v $ +! Revision 1.2 2004/09/21 18:50:24 salam +! Various speed improvements in evaluation of grid quantities; added WGPLG to special functions -- no longer need CERNLIB linkage +! +! Revision 1.1.1.1 1996/04/01 15:02:59 mclareni +! Mathlib gen +! +! +! imp64.inc +! + + + + + + + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +!# 13 "cgplg64.F" 2 +!# 1 "gen/defc64.inc" 1 +! +! $Id: special_functions.f90,v 1.2 2004/09/21 18:50:24 salam Exp $ +! +! $Log: special_functions.f90,v $ +! Revision 1.2 2004/09/21 18:50:24 salam +! Various speed improvements in evaluation of grid quantities; added WGPLG to special functions -- no longer need CERNLIB linkage +! +! Revision 1.1.1.1 1996/04/01 15:02:59 mclareni +! Mathlib gen +! +! +! defc64.inc +! + + + + + + + + COMPLEX*16 & + & WGPLG +!# 14 "cgplg64.F" 2 + + + + + + +!# 1 "gen/defc64.inc" 1 +! +! $Id: special_functions.f90,v 1.2 2004/09/21 18:50:24 salam Exp $ +! +! $Log: special_functions.f90,v $ +! Revision 1.2 2004/09/21 18:50:24 salam +! Various speed improvements in evaluation of grid quantities; added WGPLG to special functions -- no longer need CERNLIB linkage +! +! Revision 1.1.1.1 1996/04/01 15:02:59 mclareni +! Mathlib gen +! +! +! defc64.inc +! + + + + + + + + COMPLEX*16 & + & Z,I,V(0:5),SK,SJ +!# 22 "cgplg64.F" 2 +! + CHARACTER NAME*(*) + CHARACTER*80 ERRTXT + + PARAMETER (NAME = 'CGPLG/WGPLG') + + + + + DIMENSION FCT(0:4),SGN(0:4),U(0:4),S1(4,4),C(4,4),A(0:30,10) + DIMENSION NC(10),INDEX(31) + + PARAMETER (I = (0,1)) + PARAMETER (Z0 = 0, Z1 = 1, HF = Z1/2, C1 = 4*Z1/3, C2 = Z1/3) + + DATA FCT /1,1,2,6,24/, SGN /1,-1,1,-1,1/ + + DATA S1(1,1) /1.6449340668482D0/ + DATA S1(1,2) /1.2020569031596D0/ + DATA S1(1,3) /1.0823232337111D0/ + DATA S1(1,4) /1.0369277551434D0/ + DATA S1(2,1) /1.2020569031596D0/ + DATA S1(2,2) /2.7058080842778D-1/ + DATA S1(2,3) /9.6551159989444D-2/ + DATA S1(3,1) /1.0823232337111D0/ + DATA S1(3,2) /9.6551159989444D-2/ + DATA S1(4,1) /1.0369277551434D0/ + + DATA C(1,1) / 1.6449340668482D0/ + DATA C(1,2) / 1.2020569031596D0/ + DATA C(1,3) / 1.0823232337111D0/ + DATA C(1,4) / 1.0369277551434D0/ + DATA C(2,1) / 0.0000000000000D0/ + DATA C(2,2) /-1.8940656589945D0/ + DATA C(2,3) /-3.0142321054407D0/ + DATA C(3,1) / 1.8940656589945D0/ + DATA C(3,2) / 3.0142321054407D0/ + DATA C(4,1) / 0.0000000000000D0/ + + DATA INDEX /1,2,3,4,6*0,5,6,7,7*0,8,9,8*0,10/ + + DATA NC /24,26,28,30,22,24,26,19,22,17/ + + DATA A( 0,1) / .96753215043498D0/ + DATA A( 1,1) / .16607303292785D0/ + DATA A( 2,1) / .02487932292423D0/ + DATA A( 3,1) / .00468636195945D0/ + DATA A( 4,1) / .00100162749616D0/ + DATA A( 5,1) / .00023200219609D0/ + DATA A( 6,1) / .00005681782272D0/ + DATA A( 7,1) / .00001449630056D0/ + DATA A( 8,1) / .00000381632946D0/ + DATA A( 9,1) / .00000102990426D0/ + DATA A(10,1) / .00000028357538D0/ + DATA A(11,1) / .00000007938705D0/ + DATA A(12,1) / .00000002253670D0/ + DATA A(13,1) / .00000000647434D0/ + DATA A(14,1) / .00000000187912D0/ + DATA A(15,1) / .00000000055029D0/ + DATA A(16,1) / .00000000016242D0/ + DATA A(17,1) / .00000000004827D0/ + DATA A(18,1) / .00000000001444D0/ + DATA A(19,1) / .00000000000434D0/ + DATA A(20,1) / .00000000000131D0/ + DATA A(21,1) / .00000000000040D0/ + DATA A(22,1) / .00000000000012D0/ + DATA A(23,1) / .00000000000004D0/ + DATA A(24,1) / .00000000000001D0/ + + DATA A( 0,2) / .95180889127832D0/ + DATA A( 1,2) / .43131131846532D0/ + DATA A( 2,2) / .10002250714905D0/ + DATA A( 3,2) / .02442415595220D0/ + DATA A( 4,2) / .00622512463724D0/ + DATA A( 5,2) / .00164078831235D0/ + DATA A( 6,2) / .00044407920265D0/ + DATA A( 7,2) / .00012277494168D0/ + DATA A( 8,2) / .00003453981284D0/ + DATA A( 9,2) / .00000985869565D0/ + DATA A(10,2) / .00000284856995D0/ + DATA A(11,2) / .00000083170847D0/ + DATA A(12,2) / .00000024503950D0/ + DATA A(13,2) / .00000007276496D0/ + DATA A(14,2) / .00000002175802D0/ + DATA A(15,2) / .00000000654616D0/ + DATA A(16,2) / .00000000198033D0/ + DATA A(17,2) / .00000000060204D0/ + DATA A(18,2) / .00000000018385D0/ + DATA A(19,2) / .00000000005637D0/ + DATA A(20,2) / .00000000001735D0/ + DATA A(21,2) / .00000000000536D0/ + DATA A(22,2) / .00000000000166D0/ + DATA A(23,2) / .00000000000052D0/ + DATA A(24,2) / .00000000000016D0/ + DATA A(25,2) / .00000000000005D0/ + DATA A(26,2) / .00000000000002D0/ + + DATA A( 0,3) / .98161027991365D0/ + DATA A( 1,3) / .72926806320726D0/ + DATA A( 2,3) / .22774714909321D0/ + DATA A( 3,3) / .06809083296197D0/ + DATA A( 4,3) / .02013701183064D0/ + DATA A( 5,3) / .00595478480197D0/ + DATA A( 6,3) / .00176769013959D0/ + DATA A( 7,3) / .00052748218502D0/ + DATA A( 8,3) / .00015827461460D0/ + DATA A( 9,3) / .00004774922076D0/ + DATA A(10,3) / .00001447920408D0/ + DATA A(11,3) / .00000441154886D0/ + DATA A(12,3) / .00000135003870D0/ + DATA A(13,3) / .00000041481779D0/ + DATA A(14,3) / .00000012793307D0/ + DATA A(15,3) / .00000003959070D0/ + DATA A(16,3) / .00000001229055D0/ + DATA A(17,3) / .00000000382658D0/ + DATA A(18,3) / .00000000119459D0/ + DATA A(19,3) / .00000000037386D0/ + DATA A(20,3) / .00000000011727D0/ + DATA A(21,3) / .00000000003687D0/ + DATA A(22,3) / .00000000001161D0/ + DATA A(23,3) / .00000000000366D0/ + DATA A(24,3) / .00000000000116D0/ + DATA A(25,3) / .00000000000037D0/ + DATA A(26,3) / .00000000000012D0/ + DATA A(27,3) / .00000000000004D0/ + DATA A(28,3) / .00000000000001D0/ + + DATA A( 0,4) /1.0640521184614D0/ + DATA A( 1,4) /1.0691720744981D0/ + DATA A( 2,4) / .41527193251768D0/ + DATA A( 3,4) / .14610332936222D0/ + DATA A( 4,4) / .04904732648784D0/ + DATA A( 5,4) / .01606340860396D0/ + DATA A( 6,4) / .00518889350790D0/ + DATA A( 7,4) / .00166298717324D0/ + DATA A( 8,4) / .00053058279969D0/ + DATA A( 9,4) / .00016887029251D0/ + DATA A(10,4) / .00005368328059D0/ + DATA A(11,4) / .00001705923313D0/ + DATA A(12,4) / .00000542174374D0/ + DATA A(13,4) / .00000172394082D0/ + DATA A(14,4) / .00000054853275D0/ + DATA A(15,4) / .00000017467795D0/ + DATA A(16,4) / .00000005567550D0/ + DATA A(17,4) / .00000001776234D0/ + DATA A(18,4) / .00000000567224D0/ + DATA A(19,4) / .00000000181313D0/ + DATA A(20,4) / .00000000058012D0/ + DATA A(21,4) / .00000000018579D0/ + DATA A(22,4) / .00000000005955D0/ + DATA A(23,4) / .00000000001911D0/ + DATA A(24,4) / .00000000000614D0/ + DATA A(25,4) / .00000000000197D0/ + DATA A(26,4) / .00000000000063D0/ + DATA A(27,4) / .00000000000020D0/ + DATA A(28,4) / .00000000000007D0/ + DATA A(29,4) / .00000000000002D0/ + DATA A(30,4) / .00000000000001D0/ + + DATA A( 0,5) / .97920860669175D0/ + DATA A( 1,5) / .08518813148683D0/ + DATA A( 2,5) / .00855985222013D0/ + DATA A( 3,5) / .00121177214413D0/ + DATA A( 4,5) / .00020722768531D0/ + DATA A( 5,5) / .00003996958691D0/ + DATA A( 6,5) / .00000838064065D0/ + DATA A( 7,5) / .00000186848945D0/ + DATA A( 8,5) / .00000043666087D0/ + DATA A( 9,5) / .00000010591733D0/ + DATA A(10,5) / .00000002647892D0/ + DATA A(11,5) / .00000000678700D0/ + DATA A(12,5) / .00000000177654D0/ + DATA A(13,5) / .00000000047342D0/ + DATA A(14,5) / .00000000012812D0/ + DATA A(15,5) / .00000000003514D0/ + DATA A(16,5) / .00000000000975D0/ + DATA A(17,5) / .00000000000274D0/ + DATA A(18,5) / .00000000000077D0/ + DATA A(19,5) / .00000000000022D0/ + DATA A(20,5) / .00000000000006D0/ + DATA A(21,5) / .00000000000002D0/ + DATA A(22,5) / .00000000000001D0/ + + DATA A( 0,6) / .95021851963952D0/ + DATA A( 1,6) / .29052529161433D0/ + DATA A( 2,6) / .05081774061716D0/ + DATA A( 3,6) / .00995543767280D0/ + DATA A( 4,6) / .00211733895031D0/ + DATA A( 5,6) / .00047859470550D0/ + DATA A( 6,6) / .00011334321308D0/ + DATA A( 7,6) / .00002784733104D0/ + DATA A( 8,6) / .00000704788108D0/ + DATA A( 9,6) / .00000182788740D0/ + DATA A(10,6) / .00000048387492D0/ + DATA A(11,6) / .00000013033842D0/ + DATA A(12,6) / .00000003563769D0/ + DATA A(13,6) / .00000000987174D0/ + DATA A(14,6) / .00000000276586D0/ + DATA A(15,6) / .00000000078279D0/ + DATA A(16,6) / .00000000022354D0/ + DATA A(17,6) / .00000000006435D0/ + DATA A(18,6) / .00000000001866D0/ + DATA A(19,6) / .00000000000545D0/ + DATA A(20,6) / .00000000000160D0/ + DATA A(21,6) / .00000000000047D0/ + DATA A(22,6) / .00000000000014D0/ + DATA A(23,6) / .00000000000004D0/ + DATA A(24,6) / .00000000000001D0/ + + DATA A( 0,7) / .95064032186777D0/ + DATA A( 1,7) / .54138285465171D0/ + DATA A( 2,7) / .13649979590321D0/ + DATA A( 3,7) / .03417942328207D0/ + DATA A( 4,7) / .00869027883583D0/ + DATA A( 5,7) / .00225284084155D0/ + DATA A( 6,7) / .00059516089806D0/ + DATA A( 7,7) / .00015995617766D0/ + DATA A( 8,7) / .00004365213096D0/ + DATA A( 9,7) / .00001207474688D0/ + DATA A(10,7) / .00000338018176D0/ + DATA A(11,7) / .00000095632476D0/ + DATA A(12,7) / .00000027313129D0/ + DATA A(13,7) / .00000007866968D0/ + DATA A(14,7) / .00000002283195D0/ + DATA A(15,7) / .00000000667205D0/ + DATA A(16,7) / .00000000196191D0/ + DATA A(17,7) / .00000000058018D0/ + DATA A(18,7) / .00000000017246D0/ + DATA A(19,7) / .00000000005151D0/ + DATA A(20,7) / .00000000001545D0/ + DATA A(21,7) / .00000000000465D0/ + DATA A(22,7) / .00000000000141D0/ + DATA A(23,7) / .00000000000043D0/ + DATA A(24,7) / .00000000000013D0/ + DATA A(25,7) / .00000000000004D0/ + DATA A(26,7) / .00000000000001D0/ + + DATA A( 0,8) / .98800011672229D0/ + DATA A( 1,8) / .04364067609601D0/ + DATA A( 2,8) / .00295091178278D0/ + DATA A( 3,8) / .00031477809720D0/ + DATA A( 4,8) / .00004314846029D0/ + DATA A( 5,8) / .00000693818230D0/ + DATA A( 6,8) / .00000124640350D0/ + DATA A( 7,8) / .00000024293628D0/ + DATA A( 8,8) / .00000005040827D0/ + DATA A( 9,8) / .00000001099075D0/ + DATA A(10,8) / .00000000249467D0/ + DATA A(11,8) / .00000000058540D0/ + DATA A(12,8) / .00000000014127D0/ + DATA A(13,8) / .00000000003492D0/ + DATA A(14,8) / .00000000000881D0/ + DATA A(15,8) / .00000000000226D0/ + DATA A(16,8) / .00000000000059D0/ + DATA A(17,8) / .00000000000016D0/ + DATA A(18,8) / .00000000000004D0/ + DATA A(19,8) / .00000000000001D0/ + + DATA A( 0,9) / .95768506546350D0/ + DATA A( 1,9) / .19725249679534D0/ + DATA A( 2,9) / .02603370313918D0/ + DATA A( 3,9) / .00409382168261D0/ + DATA A( 4,9) / .00072681707110D0/ + DATA A( 5,9) / .00014091879261D0/ + DATA A( 6,9) / .00002920458914D0/ + DATA A( 7,9) / .00000637631144D0/ + DATA A( 8,9) / .00000145167850D0/ + DATA A( 9,9) / .00000034205281D0/ + DATA A(10,9) / .00000008294302D0/ + DATA A(11,9) / .00000002060784D0/ + DATA A(12,9) / .00000000522823D0/ + DATA A(13,9) / .00000000135066D0/ + DATA A(14,9) / .00000000035451D0/ + DATA A(15,9) / .00000000009436D0/ + DATA A(16,9) / .00000000002543D0/ + DATA A(17,9) / .00000000000693D0/ + DATA A(18,9) / .00000000000191D0/ + DATA A(19,9) / .00000000000053D0/ + DATA A(20,9) / .00000000000015D0/ + DATA A(21,9) / .00000000000004D0/ + DATA A(22,9) / .00000000000001D0/ + + DATA A( 0,10) / .99343651671347D0/ + DATA A( 1,10) / .02225770126826D0/ + DATA A( 2,10) / .00101475574703D0/ + DATA A( 3,10) / .00008175156250D0/ + DATA A( 4,10) / .00000899973547D0/ + DATA A( 5,10) / .00000120823987D0/ + DATA A( 6,10) / .00000018616913D0/ + DATA A( 7,10) / .00000003174723D0/ + DATA A( 8,10) / .00000000585215D0/ + DATA A( 9,10) / .00000000114739D0/ + DATA A(10,10) / .00000000023652D0/ + DATA A(11,10) / .00000000005082D0/ + DATA A(12,10) / .00000000001131D0/ + DATA A(13,10) / .00000000000259D0/ + DATA A(14,10) / .00000000000061D0/ + DATA A(15,10) / .00000000000015D0/ + DATA A(16,10) / .00000000000004D0/ + DATA A(17,10) / .00000000000001D0/ + + IF(N .LT. 1 .OR. N .GT. 4 .OR. M .LT. 1 .OR. M .GT. 4 .OR. & + & N+M .GT. 5) THEN + Z=0 + WRITE(ERRTXT,101) N,M + CALL MTLPRT(NAME,'C321.1',ERRTXT) + ELSEIF(X .EQ. 1) THEN + Z=S1(N,M) + ELSEIF(X .GT. 2 .OR. X .LT. -1) THEN + X1=1/X + H=C1*X1+C2 + ALFA=H+H + V(0)=1 + V(1)=LOG(-X+I*Z0) + DO 33 L = 2,N+M + 33 V(L)=V(1)*V(L-1)/L + SK=0 + DO 34 K = 0,M-1 + M1=M-K + R=X1**M1/(FCT(M1)*FCT(N-1)) + SJ=0 + DO 35 J = 0,K + N1=N+K-J + L=INDEX(10*N1+M1-10) + B1=0 + B2=0 + DO 31 IT = NC(L),0,-1 + B0=A(IT,L)+ALFA*B1-B2 + B2=B1 + 31 B1=B0 + Q=(FCT(N1-1)/FCT(K-J))*(B0-H*B2)*R/M1**N1 + 35 SJ=SJ+V(J)*Q + 34 SK=SK+SGN(K)*SJ + SJ=0 + DO 36 J = 0,N-1 + 36 SJ=SJ+V(J)*C(N-J,M) + Z=SGN(N)*SK+SGN(M)*(SJ+V(N+M)) + ELSEIF(X .GT. HF) THEN + X1=1-X + H=C1*X1+C2 + ALFA=H+H + V(0)=1 + U(0)=1 + V(1)=LOG(X1+I*Z0) + U(1)=LOG(X) + DO 23 L = 2,M + 23 V(L)=V(1)*V(L-1)/L + DO 26 L = 2,N + 26 U(L)=U(1)*U(L-1)/L + SK=0 + DO 24 K = 0,N-1 + M1=N-K + R=X1**M1/FCT(M1) + SJ=0 + DO 25 J = 0,M-1 + N1=M-J + L=INDEX(10*N1+M1-10) + B1=0 + B2=0 + DO 12 IT = NC(L),0,-1 + B0=A(IT,L)+ALFA*B1-B2 + B2=B1 + 12 B1=B0 + Q=SGN(J)*(B0-H*B2)*R/M1**N1 + 25 SJ=SJ+V(J)*Q + 24 SK=SK+U(K)*(S1(M1,M)-SJ) + Z=SK+SGN(M)*U(N)*V(M) + ELSE + L=INDEX(10*N+M-10) + H=C1*X+C2 + ALFA=H+H + B1=0 + B2=0 + DO 11 IT = NC(L),0,-1 + B0=A(IT,L)+ALFA*B1-B2 + B2=B1 + 11 B1=B0 + Z=(B0-H*B2)*X**M/(FCT(M)*M**N) + ENDIF + + WGPLG=Z + + + + + RETURN + 101 FORMAT('ILLEGAL VALUES N = ',I3,' M = ',I3) + END function wgplg + + + !-------------------------------------------- + !-- a very abbreviated version of mtlprt + SUBROUTINE MTLPRT(NAME,ERC,TEXT) + CHARACTER(len=*) NAME,ERC,TEXT + WRITE( *,100) ERC(1:4),NAME,ERC,trim(TEXT) + stop +100 FORMAT(7X,'***** CERN ',A,1X,A,' ERROR ',A,': ',A) + END SUBROUTINE MTLPRT + +end module special_functions + diff --git a/src/splitting_functions.f90 b/src/splitting_functions.f90 new file mode 100644 index 0000000..ebb828f --- /dev/null +++ b/src/splitting_functions.f90 @@ -0,0 +1,1007 @@ +!====================================================================== +! Consider the following possibility: want special types for +! set of LO splitting functions +! set of coefficient functions + +!---------------------------------------------------------------------- +! NB: compared to all normal splitting functions we have multiplied +! by x, to allow for integration measure. NB: this applies also +! to the plus functions, which do not care about integration measures? +! +! \int dx f(x)_+ g(x) = \int dy [exp(-y)f(exp(-y))]_+ g(exp(-y)) +! +! +module splitting_functions + use types; use consts_dp; use convolution_communicator + use coefficient_functions; use qcd; use warnings_and_errors + !! early estimate of splitting function based on fit to moments + !!use splitting_functions_nnlo_n + !! parametrization of exact splitting functions + !!use splitting_functions_nnlo_p + ! this one gives a set that depends on imod. + use splitting_functions_nnlo + implicit none + private + + public :: sf_Pgg, sf_Pqq, sf_Pgq, sf_Pqg + public :: sf_P1qqV, sf_P1gg, sf_P1qqbarV, sf_P1qqS, sf_P1qg, sf_P1gq + public :: sf_P1qqBryan, sf_P1qgBryan, sf_P1minus + public :: sf_P1fromg, sf_P1fromq + public :: sf_P1qqV_DIS, sf_P1qg_DIS + + public :: sf_A2PShq, sf_A2PShg, sf_A2PShg_vogt + public :: sf_A2NSqq_H, sf_A2Sgg_H, sf_A2Sgq_H + + public :: sf_P2gg, sf_P2qg2nf, sf_P2PS, sf_P2gq + public :: sf_P2NSPlus, sf_P2NSMinus, sf_P2NSS + + public :: sf_DPqq, sf_DPqg, sf_DPgq, sf_DPgg + public :: sf_DP1qqV, sf_DP1qqbarV, sf_DP1qqS + public :: sf_DP1qg, sf_DP1gq, sf_DP1gg + +!!$ ! these are of help elsewhere in identifying (run-time) the sets of +!!$ ! splitting functions that have been used? +!!$ public :: name_xpij2, name_xpns2 + + real(dp), parameter :: four_thirds = four/three + +contains + !---------------------------------------------------------------------- + function sf_Pgg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = two*ca*(x/(one-x) + (one-x)/x + x*(1-x)) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - two*ca*one/(one-x) + case(cc_DELTA) + res = (11.0_dp*ca - four*nf*tr)/6.0_dp + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_Pgg + + !---------------------------------------------------------------------- + function sf_Pqq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = cf*(one+x**2)/(one-x) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - cf*two/(one-x) + case(cc_DELTA) + res = cf*three*half + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_Pqq + + !---------------------------------------------------------------------- + function sf_Pgq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = cf*(one + (one-x)**2)/x + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_Pgq + + !---------------------------------------------------------------------- + function sf_Pqg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = tr*(x**2 + (one-x)**2) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_Pqg + + + + !====================================================================== + ! From here onwards, the NLO splitting functions + function sf_P1qqV(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx, pqq + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x); ln1mx = log(one - x) + pqq = two/(one-x) - one - x +!!$ res = cf**2*( -(two*lnx*ln1mx + 1.5_dp*lnx)*pqq& +!!$ & -(1.5_dp + 3.5_dp*x)*lnx - half*(one+x)*lnx**2 - 5*(1-x))& +!!$ & + cf*ca*( (half*lnx**2 + 11/6.0_dp * lnx& +!!$ & + 67/18.0_dp - pi**2/6.0_dp) * pqq + (1+x)*lnx& +!!$ & + 20/three*(1-x))& +!!$ & + cf*tf*(-(two/three*lnx + 10/9.0_dp)*pqq - four/three*(1-x)) +res= CF*Tf*((-1.1111111111111112_dp - (2*lnx)/3._dp)*pqq - & + & (4*(1 - x))/3._dp) + & + & CA*CF*((3.7222222222222223_dp + (11*lnx)/6._dp + lnx**2/2._dp -& + & Pi**2/6._dp)*pqq + (20*(1 - x))/3._dp + lnx*(1 + x)) + & + & CF**2*(((-3*lnx)/2._dp - 2*ln1mx*lnx)*pqq - 5*(1 - x) - & + & (lnx**2*(1 + x))/2._dp - lnx*(1.5_dp + (7*x)/2._dp)) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + pqq = -two/(1-x) + res = res + CA*CF*(3.7222222222222223_dp - Pi**2/6._dp)*pqq - (10*CF& + & *pqq*Tf)/9._dp + case(cc_DELTA) + res = -(CF*(0.16666666666666666_dp + (2*Pi**2)/9._dp)*Tf) + CA& + & *CF*(0.7083333333333334_dp + (11*Pi**2)/18._dp - 3*zeta3) +& + & CF**2*(0.375_dp - Pi**2/2._dp + 6*zeta3) + end select + + if (cc_piece /= cc_DELTA) res = res * x + + end function sf_P1qqV + + + !====================================================================== + ! DIS version of the above. + ! Currently the formulae are wrong. Use the complete formulae from + ! module dglap_holders (where double convolutions are used to work them out). + function sf_P1qqV_DIS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + + write(0,*) 'sf_P1qqV_DIS: DIS scheme splitting functions & + ¤tly not supported' + stop + res = sf_P1qqV(y) - cf_CqF2MSbar(y)*(11*CA - 2*nf)/6.0_dp + end function sf_P1qqV_DIS + + + + !---------------------------------------------------------------------- + function sf_P1gg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx, pgg, S2x, pggmx + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x); ln1mx = log(one - x) + pgg = (one/(one-x) + one/x -two + x*(one-x)) + pggmx = (one/(one+x) - one/x -two - x*(one+x)) + S2x = sf_S2(x) + res = CF*Tf*(-16 + 4/(3._dp*x) + 8*x + (20*x**2)/3._dp - lnx**2*(2& + & + 2*x)- lnx*(6 + 10*x)) + CA*Tf*(2 - (20*pgg)/9._dp - 2*x -& + & (4*lnx*(1 + x))/3._dp + (26*(-(1/x) + x**2))/9._dp) + CA**2& + & *(pgg*(7.444444444444445_dp - 4*ln1mx*lnx + lnx**2 - Pi**2& + & /3._dp) + 2*pggmx*S2x + (27*(1 - x))/2._dp + 4*lnx**2*(1 + x)& + & + (67*(-(1/x) + x**2))/9._dp - lnx*(8.333333333333334_dp -& + & (11*x)/3._dp + (44*x**2)/3._dp)) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + pgg = -one/(1-x) + res = res + CA**2*pgg*(7.444444444444445_dp - Pi**2/3._dp) - (20*CA& + & *pgg*Tf)/9._dp + case(cc_DELTA) + res = (-4*CA*Tf)/3._dp - CF*Tf + CA**2*(2.6666666666666665_dp& + & + 3*zeta3) + end select + + if (cc_piece /= cc_DELTA) res = res * x + + end function sf_P1gg + + + !---------------------------------------------------------------------- + function sf_P1qqbarV(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, pqqmx, S2x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x) + pqqmx = two/(one+x) - one + x + S2x = sf_S2(x) + res = CF*(-CA/2._dp + CF)*(2*pqqmx*S2x + 4*(1 - x) + 2*lnx*(1 + x)) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P1qqbarV + + !---------------------------------------------------------------------- + function sf_P1qqS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x); ln1mx = log(one - x) + res = (CF*TR*(20 - 9*(2 - lnx + lnx**2)*x - 9*(-6 - 5*lnx + lnx& + & **2)*x**2 + 8*(-7 + 3*lnx)*x**3))/(9._dp*x) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P1qqS + + + !---------------------------------------------------------------------- + function sf_P1qg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx, pqg, pqgmx, S2x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x); ln1mx = log(one - x) + pqg = x**2 + (one-x)**2 + pqgmx = x**2 + (one+x)**2 + S2x = sf_S2(x) + res = CF*(half*TR)*(4 + 4*ln1mx + (10 - 4*(ln1mx - lnx) + 2*(-ln1mx& + & + lnx)& + & **2 - (2*Pi**2)/3._dp)* pqg - lnx*(1 - 4*x) - lnx**2*(1 - 2& + & *x) - 9*x) + CA*(half*TR)*(20.22222222222222_dp - 4*ln1mx + (& + & -24.22222222222222_dp + 4*ln1mx - 2*ln1mx**2 + (44*lnx)/3._dp& + & - lnx**2 + Pi**2/3._dp)*pqg + 2*pqgmx*S2x + 40/(9._dp*x) +& + & (14*x)/9._dp - lnx**2*(2 + 8*x) + lnx*(-12.666666666666666_dp& + & + (136*x)/3._dp)) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P1qg + + + !====================================================================== + ! DIS version of the above + function sf_P1qg_DIS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + + write(0,*) 'sf_P1qg_DIS: DIS scheme splitting functions currently not supported' + stop + res = sf_P1qg(y) - cf_CgF2MSbar(y)*(11*CA - 2*nf)/6.0_dp + end function sf_P1qg_DIS + + + !---------------------------------------------------------------------- + function sf_P1gq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx, pgq, pgqmx,S2x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x); ln1mx = log(one - x) + pgq = (one + (one-x)**2)/x + pgqmx = -(one + (one+x)**2)/x + S2x = sf_S2(x) + res = CF*Tf*(-((2.2222222222222223_dp + (4*ln1mx)/3._dp)*pgq) - (4& + & *x)/3._dp) + CF**2*(-2.5_dp - (3*ln1mx + ln1mx**2)*pgq - lnx& + & **2*(1 - x/2._dp) - (7*x)/2._dp - 2*ln1mx*x + lnx*(2 + (7*x)& + & /2._dp)) + CA*CF*(3.111111111111111_dp + pgq*(0.5_dp + (11& + & *ln1mx)/3._dp + ln1mx**2 - 2*ln1mx*lnx + lnx**2/2._dp - Pi**2& + & /6._dp) + pgqmx*S2x + (65*x)/18._dp + 2*ln1mx*x + (44*x**2)& + & /9._dp + lnx**2*(4 + x) - lnx*(12 + 5*x + (8*x**2)/3._dp)) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P1gq + + + !====================================================================== + ! Alternative versions of the splitting functions, more similar + ! to what is in the ESW book + ! and some things for checking sum rules more easily + function sf_P1qqBryan(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + res = sf_P1qqV(y) + sf_P1qqbarV(y) + two*nf * sf_P1qqS(y) + !res = sf_P1qqBryanTyped(y) + end function sf_P1qqBryan + function sf_P1qgBryan(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + res = two*nf * sf_P1qg(y) + end function sf_P1qgBryan + function sf_P1minus(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + res = sf_P1qqV(y) - sf_P1qqbarV(y) + end function sf_P1minus + function sf_P1fromq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + res = sf_P1qqBryan(y) + sf_P1gq(y) + end function sf_P1fromq + function sf_P1fromg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + res = sf_P1gg(y) + sf_P1qgBryan(y) + end function sf_P1fromg + + + !---------------------------------------------------------------------- + ! Following was useful for debugging purposes... + function sf_P1qqBryanTyped(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx, pqq, pqqmx, S2x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = log(x); ln1mx = log(one - x) + pqq = two/(one-x) - one - x + pqqmx = two/(one+x) - one + x + S2x = sf_S2(x) + res = CA*CF*((3.7222222222222223_dp + (11*lnx)/6._dp + lnx**2/2._dp& + & - Pi**2/6._dp)*pqq - pqqmx*S2x + (14*(1 - x))/3._dp) +& + & CF**2*(-1 - ((3*lnx)/2._dp + 2*ln1mx*lnx)*pqq + 2*pqqmx*S2x + & + & lnx*(0.5_dp - (3*x)/2._dp) + x - (lnx**2*(1 + x))/2._dp) +& + & CF*Tf*(-5.333333333333333_dp - & + & (1.1111111111111112_dp + (2*lnx)/3._dp)*pqq + 40/(9._dp*x) +& + & (40*x)/3._dp - (112*x**2)/9._dp - 2*lnx**2*(1 + x) +& + & lnx*(2 + 10*x + (16*x**2)/3._dp)) + + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + pqq = -two/(1-x) + res = res + CA*CF*(3.7222222222222223_dp - Pi**2/6._dp)*pqq - (10*CF& + & *pqq*Tf)/9._dp + case(cc_DELTA) + res = -(CF*(0.16666666666666666_dp + (2*Pi**2)/9._dp)*Tf) + CA& + & *CF*(0.7083333333333334_dp + (11*Pi**2)/18._dp - 3*zeta3) +& + & CF**2*(0.375_dp - Pi**2/2._dp + 6*zeta3) + end select + + if (cc_piece /= cc_DELTA) res = res * x + + end function sf_P1qqBryanTyped + + + + !====================================================================== + ! helper... + function sf_S2(x) result(S2) + use special_functions + real(dp), intent(in) :: x + real(dp) :: S2, lnx + lnx = log(x) + S2 = -two*ddilog(-x) + half * lnx**2 - two*lnx*log(one+x) - pi**2& + & /6.0_dp + end function sf_S2 + + + !====================================================================== + ! What follows is stuff for VFNS. + ! It has been hacked in one way or another from the code provided + ! by W.L. van Neerven (~/src/HEP/vannerven-vfns.f), and appropriate + ! citations are + ! + ! M. Buza, Y. Matiounine, J. Smith, R. Migneron, W.L. van Neerven, + ! Nucl. Phys. B472 (1996) 611, hep-ph/9601302. + ! M. Buza, Y. Matiounine, J. Smith, W.L. van Neerven, + ! Eur. Phys. J. C1 (1998) 301. + ! + ! Pieces that are going to be needed for my purposes are those from that + ! code which are free of logs of mu^2/m^2, since we will for the time being + ! keep these two scales equal (and later on, if we do not then pieces + ! with logs will be reconstructed appropriately?) + ! + ! Thus the pieces needed, in the notation of the second of the above + ! papers, are: + ! + ! For Delta (f_k + f_kbar): + ! A^{2,NS}_{qq,H} CODED + ! A^{2,PS}_{qq,H} <-- this is zero at O(as^2) + ! A^{2,S}_{qg,H} <-- this is zero at O(as^2) + ! + ! For Delta (f_H + f_Hbar) + ! A^{2,PS}_{Hq} CODED + ! A^{2,S}_{Hg} CODED + ! + ! For Delta (G) + ! A^{2,S}_{gq,H} CODED + ! A^{2,S}_{gg,H} CODED + ! + ! NB: currently using cernlib version of WGPLG. This should be hacked + ! out of CERNLIB and inserted explicitly into special functions. + !---------------------------------------------------------------------- + + !---------------------------------------------------------------------- + ! This one hacked out of vanneerven-vfns.f90 + function sf_A2Sgq_H(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: z + real(dp) :: ln1mz + z = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + ln1mz = log(one - z) + res = (four*(two/z-two+z)*ln1mz**2/3.0_dp+8.0_dp*(10.0_dp/z & + &-10.0_dp+8.0_dp*z)*ln1mz/9.0_dp+(448.0_dp/z-448.0_dp+344.0_dp*z)& + &/27.0_dp)*cf*tr + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * z + !-- recall that above results are for (as/4pi)^2, whereas + ! we actually use (as/2pi)^2 + res = res * 0.25_dp + end function sf_A2Sgq_H + + !----------------------------------------------------------------- + ! This one typed in by hand from article + function sf_A2Sgg_H(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: z + real(dp) :: lnz, lnz2, lnz3,ln1mz + z = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnz = log(z); lnz2 = lnz*lnz; lnz3 = lnz2*lnz + ln1mz = log(one - z) + res = CF*TR*(four_thirds*(1+z)*lnz3+(6+10*z)*lnz2+(32+48*z)*lnz& + &-8/z+80-48*z-24*z**2) + & + &CA*TR*((four_thirds*(1+z)*lnz2+(52+88*z)*lnz/9.0_dp& + & -four_thirds*z*ln1mz)& + & + (224/(1-z)+556/z-628+548*z-700*z**2)/27.0_dp ) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - CA*TR*224.0_dp/(27.0_dp*(1-z)) + case(cc_DELTA) + res = -15*CF*TR + CA*TR*10.0_dp/9.0_dp + end select + + if (cc_piece /= cc_DELTA) res = res * z + !-- recall that above results are for (as/4pi)^2, whereas + ! we actually use (as/2pi)^2 + res = res * 0.25_dp + end function sf_A2Sgg_H + + + !----------------------------------------------------------------- + ! This one partially hacked out of vanneerven-vfns.f90 + function sf_A2NSqq_H(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: z + real(dp) :: lnz, lnz2, ln1mz + z = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnz = log(z); lnz2 = lnz*lnz + ln1mz = log(one - z) + res = ((one+Z*Z)*(2.0D0*lnz2/3.0D0+20.0D0*lnz/9.0D0)& + &/(one-Z)+8.0D0*(one-Z)*lnz/3.0D0+44.0D0/27.0D0 & + &-268.0D0*Z/27.0D0 + 224.0_dp/(27.0_dp*(1-z)) )*CF*TR + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - (224.0_dp/(27.0_dp*(1-z)) )*CF*TR + case(cc_DELTA) + res = CF*TR*(-8*zeta3/3.0_dp + 40.0_dp*zeta2/9.0_dp+73.0_dp/18.0_dp) + end select + + if (cc_piece /= cc_DELTA) res = res * z + !-- recall that above results are for (as/4pi)^2, whereas + ! we actually use (as/2pi)^2 + res = res * 0.25_dp + end function sf_A2NSqq_H + + + !----------------------------------------------------------------- + ! This one largely hacked out of vanneerven-vfns.f90 + function sf_A2PShg(y) result(res) + use special_functions + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: z + real(dp) :: lnz, lnz2, lnz3, ln1mz, ln1mz2, ln1mz3 + real(dp) :: ln1pz, ln1pz2 + real(dp) :: S121MZ, S12MZ,S211MZ,S21MZ,S111MZ,S11MZ + real(dp) :: A01, A02, B01, B02 + !complex(dp) :: WGPLG + z = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + ! these will need to be sorted out properly + S121MZ=WGPLG(1,2,1.0D0-Z) + S12MZ=WGPLG(1,2,-Z) + S211MZ=WGPLG(2,1,1.0D0-Z) + S21MZ=WGPLG(2,1,-Z) + S111MZ=WGPLG(1,1,1.0D0-Z) + S11MZ=WGPLG(1,1,-Z) + + lnz = log(z); lnz2 = lnz*lnz; lnz3 = lnz2*lnz + ln1mz = log(one - z) + ln1mz2=ln1mz*ln1mz + ln1mz3=ln1mz2*ln1mz + ln1pz=log(1.0d0+z) + ln1pz2=ln1pz*ln1pz + + ! C_F.T_r PART + A01=(1-2._dp*z+2._dp*z*z)*(8._dp*zeta3+4._dp*ln1mz3/3._dp & + &-8._dp*ln1mz*s111mz+8._dp*zeta2*lnz-4._dp*lnz*ln1mz2+2._dp*lnz3 & + &/3._dp-8._dp*lnz*s111mz+8._dp*s211mz-24._dp*s121mz) + A02=-(4._dp+96._dp*z-64._dp*z*z)*s111mz-(4._dp-48._dp*z & + &+40._dp*z*z)*zeta2-(8._dp+48._dp*z-24._dp*z*z)*lnz*ln1mz & + &+(4._dp+8._dp*z-12._dp*z*z)*ln1mz2-(1._dp+12._dp*z-20._dp*z*z) & + &*lnz2-(52._dp*z-48._dp*z*z)*ln1mz-(16._dp+18._dp*z+48._dp*z*z) & + &*lnz+26._dp-82._dp*z+80._dp*z*z+z*z*(-16._dp*zeta2*lnz & + &+4._dp*lnz3/3._dp+ 16._dp*lnz*s111mz+ 32._dp*s121mz) + + ! c_a.t_r part + B01=(1._dp-2._dp*z+2._dp*z*z)*(-4._dp*ln1mz3/3._dp+8._dp*ln1mz & + &*s111mz-8._dp*s211mz)+(1._dp+2._dp*z+2._dp*z*z)*(-8._dp*zeta2 & + &*ln1pz-16._dp*ln1pz*s11mz-8._dp*lnz*ln1pz2+& + &4._dp*lnz2*ln1pz+8._dp*lnz & + &*s11mz-8._dp*s21mz-16._dp*s12mz)+(16._dp+64._dp*z)*(2._dp*s121mz & + &+lnz*s111mz)-(4._dp+8._dp*z)*lnz3/3._dp+(8._dp-32._dp*z & + &+16._dp*z*z)*zeta3-(16._dp+64._dp*z)*zeta2*lnz + B02=(16._dp*z+16._dp*z*z)*(s11mz+lnz*ln1pz)+(32._dp/z/3._dp+12._dp & + &+64._dp*z-272._dp*z*z/3._dp)*s111mz-(12._dp+48._dp*z & + &-260._dp*z*z/3._dp+32._dp/z/3._dp)*zeta2-4._dp*z*z*lnz*ln1mz & + &-(2._dp+8._dp*z-10._dp*z*z)*ln1mz2+& + &(2._dp+8._dp*z+46._dp*z*z/3._dp)& + &*lnz2+(4._dp+16._dp*z-16._dp*z*z)*ln1mz-(56._dp/3._dp+172._dp*z & + &/3._dp+1600._dp*z*z/9._dp)*lnz-448._dp/z/27._dp-4._dp/3._dp & + &-628._dp*z/3._dp+6352._dp*z*z/27._dp + + res = TR*(CF*(A01+A02) + CA*(B01+B02)) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * z + !-- recall that above results are for (as/4pi)^2, whereas + ! we actually use (as/2pi)^2 + res = res * 0.25_dp + end function sf_A2PShg + + !----------------------------------------------------------------- + ! This one will use Vogts parameterisation + function sf_A2PShg_vogt(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: z + real(dp) :: A2HGA, A2HGC + z = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = A2HGA(z) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + case(cc_DELTA) + res = A2HGC(zero) + end select + + if (cc_piece /= cc_DELTA) res = res * z + !-- recall that above results are for (as/4pi)^2, whereas + ! we actually use (as/2pi)^2 + res = res * 0.25_dp + end function sf_A2PShg_vogt + + + !----------------------------------------------------------------- + ! This one largely hacked out of vanneerven-vfns.f90 + function sf_A2PShq(y) result(res) + use special_functions + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: z + real(dp) :: lnz, lnz2, lnz3 + real(dp) :: S121MZ, S111MZ + real(dp) :: A0 + !complex(dp) :: WGPLG + z = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + ! these will need to be sorted out properly + S121MZ=WGPLG(1,2,1.0D0-Z) + S111MZ=WGPLG(1,1,1.0D0-Z) + + lnz = log(z); lnz2 = lnz*lnz; lnz3 = lnz2*lnz + + ! C_F.T_r PART + A0=(1._dp+Z)*(32._dp*S121MZ+16._dp*lnz*S111MZ-16._dp*ZETA2 & + &*lnz-4._dp*lnz3/3._dp)+(32._dp/Z/3._dp+8._dp-8._dp*Z-32._dp & + &*Z*Z/3._dp)*S111MZ+(-32._dp/Z/3._dp-8._dp+8._dp*Z & + &+32._dp*Z*Z/3._dp)*ZETA2+(2._dp+10._dp*Z+16._dp*Z*Z/3._dp) & + &*lnz2-(56._dp/3._dp+88._dp*Z/3._dp+448._dp*Z*Z/9._dp)*lnz & + &-448._dp/Z/27._dp-4._dp/3._dp-124._dp*Z/3._dp+1600._dp*Z*Z & + &/27._dp + + res = TR*CF*A0 + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * z + !-- recall that above results are for (as/4pi)^2, whereas + ! we actually use (as/2pi)^2 + res = res * 0.25_dp + end function sf_A2PShq + + + !====================================================================== + ! polarized splitting functions... + !====================================================================== + ! LO: from ESW. + ! Original reference: Altarelli & Parisi NPB126 (1977) 298 + !---------------------------------------------------------------------- + function sf_DPgg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = ca*(two/(one-x) - four*x + two) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - two*ca/(one-x) + case(cc_DELTA) + res = (11.0_dp*ca - four*nf*tr)/6.0_dp + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_DPgg + + !---------------------------------------------------------------------- + function sf_DPqq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = cf*(two/(1-x) - 1 - x) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - cf*two/(one-x) + case(cc_DELTA) + res = cf*three*half + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_DPqq + + !---------------------------------------------------------------------- + function sf_DPgq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = cf*(two-x) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_DPgq + + !---------------------------------------------------------------------- + function sf_DPqg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = tr*(two*x - one) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_DPqg + + !====================================================================== + ! NLO spin-dependent splitting functions + + ! THE CALCULATION OF THE TWO LOOP SPIN SPLITTING FUNCTIONS P(IJ)(1)(X). + ! By R. Mertig (NIKHEF, Amsterdam), W.L. van Neerven (Leiden U.),. + ! INLO-PUB-6-95, NIKHEF-H-95-031, Jun 1995. 33pp. + ! Published in Z.Phys.C70:637-654,1996 + ! e-Print Archive: hep-ph/9506451 + + ! The spin dependent two loop splitting functions + ! W. Vogelsang (Rutherford),. RAL-TR-96-020, Mar 1996. 25pp. + ! Published in Nucl.Phys.B475:47-72,1996 + ! e-Print Archive: hep-ph/9603366 + + ! Will use the Vogelsang paper for input. His convention coincides + ! with the one used above with regards to alphas/two and derivative + ! wrt ln Q^2. However it differs in use of nf factors. Will stay + ! consistent with the unpolarized case (i.e. not include 2nf factors). + ! + ! Tests carried out (NLL): comparison to omega=0 (N=1) momenta, eqs.54. + ! All work out (after fixing a line in wrong place), though since Pqg->0 + ! one cannot check normalisation of this one... + ! + ! He also provides coefficient functions, should one + ! wish to implement them... + + !-------------------------------------------------- + ! identical to P1qqV + function sf_DP1qqV(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + res = sf_P1qqV(y) + end function sf_DP1qqV + + !-------------------------------------------------- + ! identical to -P1qqbarV + function sf_DP1qqbarV(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + res = -sf_P1qqbarV(y) + end function sf_DP1qqbarV + + !---------------------------------------------------------------------- + ! REMEMBER: 2nf factor NOT included! + function sf_DP1qqS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx + x = exp(-y) + res = zero + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = -y + res = two*CF*TR*((1-x) - (1-3*x)*lnx - (1+x)*lnx**2) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + case(cc_DELTA) + res = zero + end select + res = res * half ! Tf->TR accounts for nf; this accounts for 2 + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_DP1qqS + + !---------------------------------------------------------------------- + ! REMEMBER: 2nf factor NOT included! + function sf_DP1qg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx, dpqg, dpqgmx, S2x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = -y; ln1mx = log(one - x) + dpqg = two*x - one + dpqgmx = -two*x - one + S2x = sf_S2(x) + res = CF*TR*(-22 + 27*x - 9*lnx + 8*(1-x)*ln1mx& + & + dpqg*(2*ln1mx**2 - 4*ln1mx*lnx & + & + lnx**2 - two/three*pisq))& + & + CA*TR*((24-22*x) - 8*(1-x)*ln1mx + (2+16*x)*lnx & + & - 2*(ln1mx**2-pisq/6.0_dp)*dpqg & + & - (2*S2x - 3*lnx**2) * dpqgmx) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + zero + case(cc_DELTA) + res = zero + end select + res = res * half ! Tf->TR accounts for nf; this accounts for 2 + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_DP1qg + + + !---------------------------------------------------------------------- + function sf_DP1gq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx, dpgq, dpgqmx,S2x + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = -y; ln1mx = log(one - x) + dpgq = 2 - x + dpgqmx = 2 + x + S2x = sf_S2(x) + res = CF*Tf*(-four/9.0_dp*(x+4) - four/three*dpgq*ln1mx)& + &+ CF**2*(-half - half*(4-x)*lnx - dpgqmx*ln1mx& + & + (-4 - ln1mx**2 + half*lnx**2)*dpgq)& + &+ CF*CA*((4-13*x)*lnx + (10+x)*ln1mx/three + (41+35*x)/9.0_dp& + & + half*(-2*S2x + 3*lnx**2)*dpgqmx & + & + (ln1mx**2 - 2*ln1mx*lnx - pisq/6.0_dp)*dpgq) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res + zero + case(cc_DELTA) + res = zero + end select + + if (cc_piece /= cc_DELTA) res = res * x + end function sf_DP1gq + + + !---------------------------------------------------------------------- + ! Vogelsang says (p.10) that delta-function parts are just those + ! of + function sf_DP1gg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + real(dp) :: lnx, ln1mx, S2x, dpgg, dpggmx + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + lnx = -y; ln1mx = log(one - x) + dpgg = one/(1-x) - 2*x + 1 + dpggmx = one/(1+x) + 2*x + 1 + S2x = sf_S2(x) + res = -CA*Tf*(4*(1-x) + four/three*(1+x)*lnx + 20.0_dp/9.0_dp*dpgg)& + &-CF*Tf*(10*(1-x) + 2*(5-x)*lnx + 2*(1+x)*lnx**2)& + &+CA**2*((29-67*x)*lnx/three - 9.5_dp*(1-x) + 4*(1+x)*lnx**2& + & - 2*S2x*dpggmx + (67.0_dp/9.0_dp - 4*ln1mx*lnx & + & + lnx**2 - Pi**2/3._dp)*dpgg) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + dpgg = -one/(1-x) + res = res + CA**2*dpgg*(67.0_dp/9.0_dp - Pi**2/3._dp) - (20*CA& + & *dpgg*Tf)/9._dp + case(cc_DELTA) + res = (-4*CA*Tf)/3._dp - CF*Tf + CA**2*(8.0_dp/three& + & + 3*zeta3) + end select + + if (cc_piece /= cc_DELTA) res = res * x + + end function sf_DP1gg + +end module splitting_functions + + + + + diff --git a/src/splitting_functions_nnlo.f90 b/src/splitting_functions_nnlo.f90 new file mode 100644 index 0000000..6639c24 --- /dev/null +++ b/src/splitting_functions_nnlo.f90 @@ -0,0 +1,821 @@ + + +!====================================================================== +! interface to exact 3-loop splitting functions, as programmed by Vogt +! (see xpij2e.f and xpns2e.f for details). +! +! There are several things to remember: +! . Vogt y == my x +! . Vogt is normalised to powers of (as/4pi)^3 +! . colour-factor dependence IS available (taken from qcd module) +! but only for CF, CA -- TR is fixed to be 1/2 +! . systematic separation in A,B,C functions needs to be +! taken into account; C function needs to be called with x=0?x +! . check inclusion of 2nf in qg piece +! +!---------------------------------------------------------------------- +module splitting_functions_nnlo_e + use types; use consts_dp; use convolution_communicator + use qcd; use warnings_and_errors + use xpij2e; use xpns2e + implicit none + private + + public :: sf_P2gg, sf_P2qg2nf, sf_P2PS, sf_P2gq + public :: sf_P2NSPlus, sf_P2NSMinus, sf_P2NSS + ! these are of help elsewhere in identifying (run-time) the sets of + ! splitting functions that have been used? + public :: name_xpij2, name_xpns2 + +contains + function sf_P2gg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = X2GGA(x, nf_int) + X2GGB(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - X2GGB(x, nf_int) + case(cc_DELTA) + res = X2GGC(zero, nf_int) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2gg + + ! ..This is the (regular) pure-singlet splitting functions P_ps^(2). + ! P_qq^(2) is obtained by adding the non-singlet quantity P_NS^(2)+. + function sf_P2PS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = X2PSA(x, nf_int) + zero + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2PS + + !-------------------------------------------------------------------- + ! this already includes the factor of 2nf + function sf_P2qg2nf(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = X2QGA(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2qg2nf + + + function sf_P2gq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = X2GQA(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2gq + + !------------------------- non-singlet pieces ------------------------ + function sf_P2NSPlus(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = X2NSPA(x, nf_int) + X2NSB(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - X2NSB(x, nf_int) + case(cc_DELTA) + res = X2NSC(zero, nf_int) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSPlus + + + function sf_P2NSMinus(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = X2NSMA(x, nf_int) + X2NSB(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - X2NSB(x, nf_int) + case(cc_DELTA) + res = X2NSC(zero, nf_int) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSMinus + + !-- according to comments in Vogt code P_S = P_V - P_- + function sf_P2NSS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = X2NSSA(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSS + + !---------------------------------------------------------------- + ! The Vogt expressions are valid only for standard colour factors + ! This routine makes sure that the appropriate conditions hold + subroutine sf_VogtValidate + if (tr == half) return + call wae_Error('sf_VogtValidate: & + &colour factors must be set to default values', & + &'in order to use the Vogt splitting function parameterisations') + end subroutine sf_VogtValidate + +end module splitting_functions_nnlo_e + + +!====================================================================== +! interface to approx 3-loop splitting functions, as parameterised by Vogt +! (see xpij2p.f and xpns2p.f for details). +! +! There are several things to remember: +! . Vogt y == my x +! . Vogt is normalised to powers of (as/4pi)^3 +! . colour-factor dependence is not available +! . systematic separation in A,B,C functions needs to be +! taken into account; C function needs to be called with x=0?x +! . check inclusion of 2nf in qg piece +! +!---------------------------------------------------------------------- +module splitting_functions_nnlo_p + use types; use consts_dp; use convolution_communicator + use qcd; use warnings_and_errors + use xpij2p; use xpns2p + implicit none + private + + public :: sf_P2gg, sf_P2qg2nf, sf_P2PS, sf_P2gq + public :: sf_P2NSPlus, sf_P2NSMinus, sf_P2NSS + ! these are of help elsewhere in identifying (run-time) the sets of + ! splitting functions that have been used? + public :: name_xpij2, name_xpns2 + +contains + function sf_P2gg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2GGA(x, nf_int) + P2GGB(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - P2GGB(x, nf_int) + case(cc_DELTA) + res = P2GGC(zero, nf_int) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2gg + + ! ..This is the (regular) pure-singlet splitting functions P_ps^(2). + ! P_qq^(2) is obtained by adding the non-singlet quantity P_NS^(2)+. + function sf_P2PS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2PSA(x, nf_int) + zero + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2PS + + !-------------------------------------------------------------------- + ! this already includes the factor of 2nf + function sf_P2qg2nf(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2QGA(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2qg2nf + + + function sf_P2gq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2GQA(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2gq + + !------------------------- non-singlet pieces ------------------------ + function sf_P2NSPlus(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2NSPA(x, nf_int) + P2NSB(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - P2NSB(x, nf_int) + case(cc_DELTA) + res = P2NSPC(zero, nf_int) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSPlus + + + function sf_P2NSMinus(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2NSMA(x, nf_int) + P2NSB(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - P2NSB(x, nf_int) + case(cc_DELTA) + res = P2NSMC(zero, nf_int) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSMinus + + !-- according to comments in Vogt code P_S = P_V - P_- + function sf_P2NSS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2NSSA(x, nf_int) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSS + + !---------------------------------------------------------------- + ! The Vogt expressions are valid only for standard colour factors + ! This routine makes sure that the appropriate conditions hold + subroutine sf_VogtValidate + if (ca == three .and. tr == half .and. cf == four/three) return + call wae_Error('sf_VogtValidate: & + &colour factors must be set to default values', & + &'in order to use the Vogt splitting function parameterisations') + end subroutine sf_VogtValidate + +end module splitting_functions_nnlo_p + + + +!====================================================================== +! interface to guessed 3-loop splitting functions, as parameterised by Vogt +! (see xpij2n.f and xpns2n.f for details). +! +! There are several things to remember: +! . Vogt y == my x +! . Vogt is normalised to powers of (as/4pi)^3 +! . colour-factor dependence is not available +! . systematic separation in A,B,C functions needs to be +! taken into account; C function needs to be called with x=0?x +! . check inclusion of 2nf in qg piece +! +!---------------------------------------------------------------------- +module splitting_functions_nnlo_n + use types; use consts_dp; use convolution_communicator + use qcd; use dglap_choices; use warnings_and_errors + use xpij2n; use xpns2n + implicit none + private + + public :: sf_P2gg, sf_P2qg2nf, sf_P2PS, sf_P2gq + public :: sf_P2NSPlus, sf_P2NSMinus, sf_P2NSS + ! these are of help elsewhere in identifying (run-time) the sets of + ! splitting functions that have been used? + public :: name_xpij2, name_xpns2 + +contains + function sf_P2gg(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2GGA(x, nf_int, nnlo_splitting_variant) + P2GGB(x, nf_int, nnlo_splitting_variant) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - P2GGB(x, nf_int, nnlo_splitting_variant) + case(cc_DELTA) + res = P2GGC(zero, nf_int, nnlo_splitting_variant) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2gg + + ! ..This is the (regular) pure-singlet splitting functions P_ps^(2). + ! P_qq^(2) is obtained by adding the non-singlet quantity P_NS^(2)+. + function sf_P2PS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2PSA(x, nf_int, nnlo_splitting_variant) + zero + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2PS + + !-------------------------------------------------------------------- + ! this already includes the factor of 2nf + function sf_P2qg2nf(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2QGA(x, nf_int, nnlo_splitting_variant) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2qg2nf + + + function sf_P2gq(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2GQA(x, nf_int, nnlo_splitting_variant) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2gq + + !------------------------- non-singlet pieces ------------------------ + function sf_P2NSPlus(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2NSPA(x, nf_int, nnlo_splitting_variant) + P2NSPB(x, nf_int, nnlo_splitting_variant) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - P2NSPB(x, nf_int, nnlo_splitting_variant) + case(cc_DELTA) + res = P2NSPC(zero, nf_int, nnlo_splitting_variant) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSPlus + + + function sf_P2NSMinus(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2NSMA(x, nf_int, nnlo_splitting_variant) + P2NSMB(x, nf_int, nnlo_splitting_variant) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - P2NSMB(x, nf_int, nnlo_splitting_variant) + case(cc_DELTA) + res = P2NSMC(zero, nf_int, nnlo_splitting_variant) + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSMinus + + !-- according to comments in Vogt code P_S = P_V - P_- + function sf_P2NSS(y) result(res) + real(dp), intent(in) :: y + real(dp) :: res + real(dp) :: x + + call sf_VogtValidate + x = exp(-y) + res = zero + + select case(cc_piece) + case(cc_REAL,cc_REALVIRT) + res = P2NSSA(x, nf_int, nnlo_splitting_variant) + end select + select case(cc_piece) + case(cc_VIRT,cc_REALVIRT) + res = res - zero + case(cc_DELTA) + res = zero + end select + + res = res / 8.0_dp ! compensate (as/4pi)^3 -> (as/2pi)^3 + if (cc_piece /= cc_DELTA) res = res * x + end function sf_P2NSS + + !---------------------------------------------------------------- + ! The Vogt expressions are valid only for standard colour factors + ! This routine makes sure that the appropriate conditions hold + subroutine sf_VogtValidate + if (ca == three .and. tr == half .and. cf == four/three) return + call wae_Error('sf_VogtValidate: & + &colour factors must be set to default values', & + &'in order to use the Vogt splitting function parameterisations') + end subroutine sf_VogtValidate + +end module splitting_functions_nnlo_n + + +!====================================================================== +! Modules for extracting selecting the relevant splitting functions, +! either "n" version, "p" versions. May be extended to +! exact versions at some later stage... +!====================================================================== +module sf_nnlo_n_rename + use splitting_functions_nnlo_n,& + &sf_n_P2gg => sf_P2gg ,& + &sf_n_P2PS => sf_P2PS ,& + &sf_n_P2qg2nf => sf_P2qg2nf ,& + &sf_n_P2gq => sf_P2gq ,& + &sf_n_P2NSPlus => sf_P2NSPlus ,& + &sf_n_P2NSMinus => sf_P2NSMinus,& + &sf_n_P2NSS => sf_P2NSS + implicit none + private + public :: sf_n_P2gg, sf_n_P2qg2nf, sf_n_P2PS, sf_n_P2gq + public :: sf_n_P2NSPlus, sf_n_P2NSMinus, sf_n_P2NSS +end module sf_nnlo_n_rename + + +module sf_nnlo_p_rename + use splitting_functions_nnlo_p,& + &sf_p_P2gg => sf_P2gg ,& + &sf_p_P2PS => sf_P2PS ,& + &sf_p_P2qg2nf => sf_P2qg2nf ,& + &sf_p_P2gq => sf_P2gq ,& + &sf_p_P2NSPlus => sf_P2NSPlus ,& + &sf_p_P2NSMinus => sf_P2NSMinus,& + &sf_p_P2NSS => sf_P2NSS + implicit none + private + public :: sf_p_P2gg, sf_p_P2qg2nf, sf_p_P2PS, sf_p_P2gq + public :: sf_p_P2NSPlus, sf_p_P2NSMinus, sf_p_P2NSS +end module sf_nnlo_p_rename + + +module sf_nnlo_e_rename + use splitting_functions_nnlo_e,& + &sf_e_P2gg => sf_P2gg ,& + &sf_e_P2PS => sf_P2PS ,& + &sf_e_P2qg2nf => sf_P2qg2nf ,& + &sf_e_P2gq => sf_P2gq ,& + &sf_e_P2NSPlus => sf_P2NSPlus ,& + &sf_e_P2NSMinus => sf_P2NSMinus,& + &sf_e_P2NSS => sf_P2NSS + implicit none + private + public :: sf_e_P2gg, sf_e_P2qg2nf, sf_e_P2PS, sf_e_P2gq + public :: sf_e_P2NSPlus, sf_e_P2NSMinus, sf_e_P2NSS +end module sf_nnlo_e_rename + + +module splitting_functions_nnlo + use types; use qcd; use dglap_choices + use warnings_and_errors + use sf_nnlo_e_rename + use sf_nnlo_p_rename + use sf_nnlo_n_rename + public :: sf_P2gg, sf_P2qg2nf, sf_P2PS, sf_P2gq + public :: sf_P2NSPlus, sf_P2NSMinus, sf_P2NSS +contains + + + real(dp) function sf_P2gg (y) result(res) + real(dp), intent(in) :: y + select case(nnlo_splitting_variant) + case(nnlo_splitting_exact) + res = sf_e_P2gg(y) + case(nnlo_splitting_param) + res = sf_p_P2gg(y) + case(nnlo_splitting_nfitav, nnlo_splitting_nfiterr1, nnlo_splitting_nfiterr2) + res = sf_n_P2gg(y) + case default + call wae_error('splitting_functions_nnlo','unrecognized imod',& + &intval=nnlo_splitting_variant) + end select + end function sf_P2gg + + real(dp) function sf_P2PS (y) result(res) + real(dp), intent(in) :: y + select case(nnlo_splitting_variant) + case(nnlo_splitting_exact) + res = sf_e_P2PS(y) + case(nnlo_splitting_param) + res = sf_p_P2PS(y) + case(nnlo_splitting_nfitav, nnlo_splitting_nfiterr1, nnlo_splitting_nfiterr2) + res = sf_n_P2PS(y) + case default + call wae_error('splitting_functions_nnlo','unrecognized imod',& + &intval=nnlo_splitting_variant) + end select + end function sf_P2PS + + real(dp) function sf_P2qg2nf (y) result(res) + real(dp), intent(in) :: y + select case(nnlo_splitting_variant) + case(nnlo_splitting_exact) + res = sf_e_P2qg2nf(y) + case(nnlo_splitting_param) + res = sf_p_P2qg2nf(y) + case(nnlo_splitting_nfitav, nnlo_splitting_nfiterr1, nnlo_splitting_nfiterr2) + res = sf_n_P2qg2nf(y) + case default + call wae_error('splitting_functions_nnlo','unrecognized imod',& + &intval=nnlo_splitting_variant) + end select + end function sf_P2qg2nf + + real(dp) function sf_P2gq (y) result(res) + real(dp), intent(in) :: y + select case(nnlo_splitting_variant) + case(nnlo_splitting_exact) + res = sf_e_P2gq(y) + case(nnlo_splitting_param) + res = sf_p_P2gq(y) + case(nnlo_splitting_nfitav, nnlo_splitting_nfiterr1, nnlo_splitting_nfiterr2) + res = sf_n_P2gq(y) + case default + call wae_error('splitting_functions_nnlo','unrecognized imod',& + &intval=nnlo_splitting_variant) + end select + end function sf_P2gq + + real(dp) function sf_P2NSPlus (y) result(res) + real(dp), intent(in) :: y + select case(nnlo_splitting_variant) + case(nnlo_splitting_exact) + res = sf_e_P2NSPlus(y) + case(nnlo_splitting_param) + res = sf_p_P2NSPlus(y) + case(nnlo_splitting_nfitav, nnlo_splitting_nfiterr1, nnlo_splitting_nfiterr2) + res = sf_n_P2NSPlus(y) + case default + call wae_error('splitting_functions_nnlo','unrecognized imod',& + &intval=nnlo_splitting_variant) + end select + end function sf_P2NSPlus + + real(dp) function sf_P2NSMinus(y) result(res) + real(dp), intent(in) :: y + select case(nnlo_splitting_variant) + case(nnlo_splitting_exact) + res = sf_e_P2NSMinus(y) + case(nnlo_splitting_param) + res = sf_p_P2NSMinus(y) + case(nnlo_splitting_nfitav, nnlo_splitting_nfiterr1, nnlo_splitting_nfiterr2) + res = sf_n_P2NSMinus(y) + case default + call wae_error('splitting_functions_nnlo','unrecognized imod',& + &intval=nnlo_splitting_variant) + end select + end function sf_P2NSMinus + + real(dp) function sf_P2NSS(y) result(res) + real(dp), intent(in) :: y + select case(nnlo_splitting_variant) + case(nnlo_splitting_exact) + res = sf_e_P2NSS(y) + case(nnlo_splitting_param) + res = sf_p_P2NSS(y) + case(nnlo_splitting_nfitav, nnlo_splitting_nfiterr1, nnlo_splitting_nfiterr2) + res = sf_n_P2NSS(y) + case default + call wae_error('splitting_functions_nnlo','unrecognized imod',& + &intval=nnlo_splitting_variant) + end select + end function sf_P2NSS +end module splitting_functions_nnlo diff --git a/src/types.f90 b/src/types.f90 new file mode 100644 index 0000000..048d842 --- /dev/null +++ b/src/types.f90 @@ -0,0 +1,42 @@ +!====================================================================== +! Basic constants needed everywhere... +! +! GPS 16/10/96 +! $Id: types.f90,v 1.2 2002/01/25 16:20:48 gsalam Exp $ +!====================================================================== + + + +!---------------------------------------------------------------------- +! The next two are maybe to be used only when it's time for a general +! rewrite? +module types + implicit none + integer, parameter :: dp = kind(1.0d0), sp = kind(1.0) +end module types +!---------------------------------------------------------------------- +module consts_dp + use types + implicit none + private + + real(dp), public, parameter :: pi =& + & 3.141592653589793238462643383279502884197_dp + real(dp), public, parameter :: twopi =& + & 6.283185307179586476925286766559005768394_dp + real(dp), public, parameter :: zeta2 =& + & 1.644934066848226436472415166646025189219_dp + real(dp), public, parameter :: zeta3 =& + & 1.202056903159594285399738161511449990765_dp + real(dp), parameter, public :: pisq =& + & 9.869604401089358618834490999876151135314_dp + real(dp), parameter, public :: eulergamma =& + & 0.577215664901532860606512090082402431042_dp + real(dp), parameter, public :: ln2 =& + & 0.693147180559945309417232121458176568076_dp + real(dp), public, parameter :: half = 0.5_dp, two = 2.0_dp + real(dp), public, parameter :: zero = 0.0_dp, one = 1.0_dp + real(dp), public, parameter :: three = 3.0_dp, four = 4.0_dp + +end module consts_dp + diff --git a/src/warnings_and_errors.f90 b/src/warnings_and_errors.f90 new file mode 100644 index 0000000..4646993 --- /dev/null +++ b/src/warnings_and_errors.f90 @@ -0,0 +1,162 @@ +!====================================================================== +!! +!! Routine for dealing with warnings that may crop up many times and +!! which should be output only a limited number of times +!! +!! In f95 could have used a special type which was preinitialised... +!! +!! $Id: warnings_and_errors.f90,v 1.6 2004/02/26 19:02:19 salam Exp $ +!====================================================================== +module warnings_and_errors + use types + implicit none + private + + integer, parameter :: base = 10000 + integer :: n_warn_sources = 0 + integer, parameter, public :: warn_id_INIT=0 + integer, parameter, public :: default_max_warn = 5 + + interface wae_warn + module procedure wae_warn_new, wae_warn_old + end interface + + public :: wae_warn, wae_error, wae_setunit + + integer, parameter :: stddev_in = 0 + integer :: stddev = stddev_in + + +contains + !--------------------------------------------------------------------- + !! Routine to allow the output of a warning up to some maximum number of + !! times after which no such warning will be issues. + !! + !! On the first call for a given kind of warning, the warn_n should + !! (must have save attribute in calling routine) should be the + !! maximum number of warnings that will be output + !! + subroutine wae_warn_new(warn_n, text, text2, text3, text4, intval, dbleval) + integer, intent(inout) :: warn_n + character(len=*), intent(in) :: text + character(len=*), intent(in), optional :: text2 + character(len=*), intent(in), optional :: text3 + character(len=*), intent(in), optional :: text4 + integer, intent(in), optional :: intval + real(kind(1d0)), intent(in), optional :: dbleval + !-------------------------------------- + + if (warn_n > 0) then + warn_n = warn_n - 1 + write(stddev,'(a)', advance='no') 'WARNING in ' + write(stddev,'(a)') text + if (present(text2)) write(stddev,'(a)') text2 + if (present(text3)) write(stddev,'(a)') text3 + if (present(text4)) write(stddev,'(a)') text4 + if (present(intval)) write(stddev,*) intval + if (present(dbleval)) write(stddev,*) dbleval + if (warn_n == 0) write(stddev,'(a)') & + &'----- No more such warnings will be issued ------' + end if + end subroutine wae_warn_new + + + !--------------------------------------------------------------------- + !! Routine to allow the output of a warning up to some maximum number of + !! times after which no such warning will be issues. + !! + !! On the first call for a given kind of warning, the warn_id should be + !! equal to warn_id_INIT; warn_id should have the SAVE attribute to + !! allow wae_warn to keep track of the number of warnings of this type + !! + subroutine wae_warn_old(max_warn, warn_id, & + &text, text2, text3, intval, dbleval) + integer, intent(in) :: max_warn + integer, intent(inout) :: warn_id + character(len=*), intent(in) :: text + character(len=*), intent(in), optional :: text2 + character(len=*), intent(in), optional :: text3 + integer, intent(in), optional :: intval + real(kind(1d0)), intent(in), optional :: dbleval + !-------------------------------------- + integer :: warn_index, nwarn + + !-- generate a new warn_id + if (warn_id <= 0) then + n_warn_sources = n_warn_sources + 1 + warn_id = n_warn_sources * base + end if + + warn_index = warn_id / base + nwarn = warn_id - warn_index*base + + if (nwarn < max_warn) then + if (max_warn > base-2) call wae_error('wae_warn',& + & 'max_warn exceeded maximum allowed value; message was', text) + !-- does this make any sense at all (GPS 8/1/03)? + if (warn_id > huge(warn_id)) call wae_error('wae_warn',& + & 'exceeded max capicity for distinct warnings; message was', text) + + warn_id = warn_id + 1 + write(stddev,'(a)', advance='no') 'WARNING in ' + write(stddev,'(a)') text + if (present(text2)) write(stddev,'(a)') text2 + if (present(text3)) write(stddev,'(a)') text3 + if (present(intval)) write(stddev,*) intval + if (present(dbleval)) write(stddev,*) dbleval + !-- if there is only an 1 warning to be written then + ! avoid cluttering screen with too many messages + if (nwarn == max_warn - 1 .and. max_warn > 1) write(stddev,'(a)') & + &'----- No more such warnings will be issued ------' + end if + end subroutine wae_warn_old + + !====================================================================== + !! Report an error and then crash (by attempting floating point exception) + !====================================================================== + subroutine wae_error(text1, text2, text3, text4, intval, dbleval) + character(len=*), intent(in) :: text1 + character(len=*), intent(in), optional :: text2 + character(len=*), intent(in), optional :: text3 + character(len=*), intent(in), optional :: text4 + integer, intent(in), optional :: intval + real(kind(1d0)), intent(in), optional :: dbleval + !real :: a,b + + write(stddev,*) + write(stddev,'(a)') '=============================================================' + write(stddev,'(a)', advance='no') 'FATAL ERROR in ' + write(stddev,'(a)') text1 + if (present(text2)) write(stddev,'(a)') text2 + if (present(text3)) write(stddev,'(a)') text3 + if (present(text4)) write(stddev,'(a)') text4 + if (present(intval)) write(stddev,*) intval + if (present(dbleval)) write(stddev,*) dbleval + + ! write(stddev,*) + ! write(stddev,'(a)') & + ! &'----- Error handler will now attempt to dump core and stop' + ! a = 1.0 + ! b = 1.0 + ! write(stddev,*) 1.0/sqrt(a-b) + ! !-- in case division by zero didn't solve problem + ! !-- works only with lf95? Needs --trace compile-time flag + ! !call error('lf95 specific traceback follows:') + ! !-- + ! stop + !call error('') + write(stddev,*) + stop + !call abort + end subroutine wae_error + + !! + !! Set the unit for all output by the warning and error routines + !! + subroutine wae_setunit(unit) + integer, intent(in) :: unit + stddev = unit + end subroutine wae_setunit + +end module warnings_and_errors + diff --git a/src/welcome_message.f90 b/src/welcome_message.f90 new file mode 100644 index 0000000..57b29f6 --- /dev/null +++ b/src/welcome_message.f90 @@ -0,0 +1,23 @@ +! keep this outside a module so that we can recompile (e.g. for +! changing version number) without modifying any dependences. +! +subroutine HoppetWelcomeMessage + write(0,'(a)') '-----------------------------------------------------------' + write(0,'(a)') ' Welcome to HOPPET v. 1.x.y ' + write(0,'(a)') ' Higher Order Perturbative Parton Evolution Toolkit ' + write(0,'(a)') ' (formerly PDFEvln/HOPPER/...) ' + write(0,'(a)') '' + write(0,'(a)') ' Written Gavin P. Salam (2001-2006)' + write(0,'(a)') '' + write(0,'(a)') ' It is made available under the GNU public license,' + write(0,'(a)') ' with the additional restriction that if you use it or any' + write(0,'(a)') ' derivative of it in scientific work then you should cite:' + write(0,'(a)') ' M. Dasgupta and G.P. Salam, Eur.Phys.J.C24:213-236,2002.' + write(0,'(a)') ' ' + write(0,'(a)') ' You are also encouraged to cite the original references,' + write(0,'(a)') ' for LO, NLO and NNLO splitting functions, the QCD' + write(0,'(a)') ' 1, 2 and 3 loop beta functions and the coupling and ' + write(0,'(a)') ' PDF and coupling mass threshold matching functions.' + write(0,'(a)') '-----------------------------------------------------------' +end subroutine HoppetWelcomeMessage + diff --git a/src/xa2hgp.f90 b/src/xa2hgp.f90 new file mode 100644 index 0000000..7e41410 --- /dev/null +++ b/src/xa2hgp.f90 @@ -0,0 +1,66 @@ +! $Id: xa2hgp.f90,v 1.1 2002/03/06 17:12:12 gsalam Exp $ +! Automatically generated from f77 file, with addition of "d0" +! From avogt@nikhef.nl Thu Feb 7 15:34:35 2002 +! Date: Wed, 6 Feb 2002 18:23:05 +0100 (MET) +! From: Andreas Vogt +! To: G. Salam +! Cc: A. Vogt +! Subject: the subroutine +! +! +! ..File: xa2hgp.f +! +! +! ..Calculation of the alpha_s^2 heavy-quark singlet operator matrix +! element (OME) a^2_Hg(x) in the MS(bar) scheme for mu_f = m_H via +! a compact parametrization involving only logarithms. +! The coupling constant is normalized as a_s = alpha_s/(4*pi). +! +! ..This quantity, presented in Appendix B of M. Buza, Y. Matiounine, +! J. Smith and W.L. van Neerven, Eur. Phys. J. C1 (1998) 301 (BSMN), +! is required for the N_f matching of the NNLO parton densities. +! +! ..The distributions (in the mathematical sense) are given as in eq. +! (B.26) of Floratos, Kounnas, Lacaze: Nucl. Phys. B192 (1981) 417. +! The name-endings A, B, and C of the functions below correspond to +! the kernel superscripts [2], [3], and [1] in that equation. +! +! ..The relative accuracy of the OME, as well as of its convolutions +! with gluon distributions, amounts to a few thousandth. +! +! ..Reference: not yet known +! hep-ph/yymmnnn +! ..The user should also cite the original calculation by BSMN. +! +! +! ===================================================================== +! +! +! ..This is the regular piece. +! + FUNCTION A2HGA (Y) + IMPLICIT REAL*8 (A-Z) +! + DL = LOG (Y) + DL1 = LOG (1.-Y) +! + A2HGA = - 24.89d0 / Y - 187.8d0 + 249.6d0 * Y - 146.8d0 * DL**2 * DL1 & + & - 1.556d0 * DL**3 - 3.292d0 * DL**2 - 93.68d0 * DL & + & - 1.111d0 * DL1**3 - 0.400d0 * DL1**2 - 2.770d0 * DL1 +! + RETURN + END +! +! --------------------------------------------------------------------- +! +! +! ..This is the 'local' piece, which has no counterpart in W. van +! Neerven's program, as it does not exist in the exact expressions. +! + FUNCTION A2HGC (Y) + IMPLICIT REAL*8 (A-Z) +! + A2HGC = - 0.006d0 +! + RETURN + END diff --git a/src/xpij2e.f b/src/xpij2e.f new file mode 100644 index 0000000..8e94eb1 --- /dev/null +++ b/src/xpij2e.f @@ -0,0 +1,1178 @@ +! $Id: xpij2e.f,v 1.2 2004/09/18 14:39:34 salam Exp $ +! Automatically generated from f77 file, with inclusion of modules +! and the placement inside a module (and some other stuff). + module xpij2e + use qcd, only: cf, ca, A3G => mvv_A3G + character(len=*), parameter :: name_xpij2 = "xpij2e" + contains +! +! ..File: xpij2e.f +! +! +! ..The exact 3-loop MS(bar) singlet splitting functions P_ij^(2) +! for the evolution of unpolarized partons densities, mu_r = mu_f. +! The expansion parameter is alpha_s/(4 pi). +! +! ..The distributions (in the mathematical sense) are given as in eq. +! (B.26) of Floratos, Kounnas, Lacaze: Nucl. Phys. B192 (1981) 417. +! The name-endings A, B, and C of the functions below correspond to +! the kernel superscripts [2], [3], and [1] in that equation. +! +! ..The code uses the package of Gehrmann and Remiddi for the harmonic +! polylogarithms published in hep-ph/0107173 = CPC 141 (2001) 296. +! +! ..References: S. Moch, J. Vermaseren and A. Vogt, +! hep-ph/0403192 (to appear in Nucl. Phys. B) +! A. Vogt, S. Moch and J. Vermaseren, +! hep-ph/0404111 (submitted to Nucl. Phys. B) +! +! ===================================================================== +! +! +! ..The (regular) pure-singlet splitting functions P_ps^(2). +! P_qq^(2) is obtained by adding the non-singlet quantity P_NS^(2)+. +! + FUNCTION X2PSA (X, NF) +! + IMPLICIT REAL*8 (A - Z) + COMPLEX*16 HC1, HC2, HC3, HC4 + INTEGER NF, NF2, N1, N2, NW, I1, I2, I3, N + PARAMETER ( N1 = -1, N2 = 1, NW = 4 ) + DIMENSION HC1(N1:N2),HC2(N1:N2,N1:N2),HC3(N1:N2,N1:N2,N1:N2), & + & HC4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HR1(N1:N2),HR2(N1:N2,N1:N2),HR3(N1:N2,N1:N2,N1:N2), & + & HR4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HI1(N1:N2),HI2(N1:N2,N1:N2),HI3(N1:N2,N1:N2,N1:N2), & + & HI4(N1:N2,N1:N2,N1:N2,N1:N2) + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0 ) +! +! ...Colour factors and an abbreviation +! + !CF = 4./3.D0 + !CA = 3.D0 + NF2 = NF*NF +! + DX = 1.D0/X +! +! ...The harmonic polylogs up to weight 4 by Gehrmann and Remiddi +! + CALL HPLOG (X, NW, HC1,HC2,HC3,HC4, HR1,HR2,HR3,HR4, & + & HI1,HI2,HI3,HI4, N1, N2) +! +! ...The splitting function in terms of the harmonic polylogs +! + gqqps2 = & + & + nf*cf*ca * ( 484.D0/3.D0 - 2528.D0/3.D0*x + 82232.D0/81.D0* & + & x**2 - 27044.D0/81.D0*dx - 16.D0/3.D0*z3 + 248.D0/3.D0*z3*x & + & - 416.D0/3.D0*z3*x**2 + 96.D0*z3*dx - 1916.D0/9.D0*z2 + 904.D& + & 0/9.D0*z2*x + 448.D0/9.D0*z2*x**2 + 512.D0/9.D0*z2*dx + 428.D0& + & /5.D0*z2**2 + 468.D0/5.D0*z2**2*x + 40.D0*Hr1(-1)*z2 + 40.D0* & + & Hr1(-1)*z2*x + 32.D0/3.D0*Hr1(-1)*z2*x**2 + 32.D0/3.D0*Hr1(-1 & + & )*z2*dx - 14260.D0/27.D0*Hr1(0) - 13216.D0/27.D0*Hr1(0)*x - & + & 18392.D0/27.D0*Hr1(0)*x**2 - 896.D0/27.D0*Hr1(0)*dx + 208.D0* & + & Hr1(0)*z3 + 144.D0*Hr1(0)*z3*x - 236.D0/3.D0*Hr1(0)*z2 + 28.D0& + & /3.D0*Hr1(0)*z2*x - 32.D0/3.D0*Hr1(0)*z2*x**2 + 1748.D0/9.D0* & + & Hr1(1) - 2912.D0/9.D0*Hr1(1)*x + 1208.D0/27.D0*Hr1(1)*x**2 + & + & 2284.D0/27.D0*Hr1(1)*dx + 8.D0*Hr1(1)*z2 - 8.D0*Hr1(1)*z2*x & + & - 32.D0/3.D0*Hr1(1)*z2*x**2 + 32.D0/3.D0*Hr1(1)*z2*dx + 256.D& + & 0/3.D0*Hr2(-1,0) + 544.D0/3.D0*Hr2(-1,0)*x + 1696.D0/9.D0* & + & Hr2(-1,0)*x**2 + 832.D0/9.D0*Hr2(-1,0)*dx + 16.D0*Hr2(0,-1)* & + & z2 ) + gqqps2 = gqqps2 + nf*cf*ca * ( - 16.D0*Hr2(0,-1)*z2*x + 1076.D0/ & + & 9.D0*Hr2(0,0) - 1588.D0/9.D0*Hr2(0,0)*x + 664.D0/3.D0*Hr2(0,0 & + & )*x**2 + 8.D0*Hr2(0,0)*z2 - 8.D0*Hr2(0,0)*z2*x + 1916.D0/9.D0 & + & *Hr2(0,1) + 728.D0/9.D0*Hr2(0,1)*x - 448.D0/9.D0*Hr2(0,1)* & + & x**2 + 320.D0/9.D0*Hr2(0,1)*dx + 16.D0*Hr2(0,1)*z2 + 16.D0* & + & Hr2(0,1)*z2*x + 104.D0/3.D0*Hr2(1,0) + 40.D0/3.D0*Hr2(1,0)*x & + & - 72.D0*Hr2(1,0)*x**2 + 24.D0*Hr2(1,0)*dx - 12.D0*Hr2(1,1) & + & + 12.D0*Hr2(1,1)*x + 16.D0/9.D0*Hr2(1,1)*x**2 - 16.D0/9.D0* & + & Hr2(1,1)*dx + 16.D0*Hr3(-1,-1,0) + 16.D0*Hr3(-1,-1,0)*x - 64.D& + & 0/3.D0*Hr3(-1,-1,0)*x**2 - 64.D0/3.D0*Hr3(-1,-1,0)*dx + 8.D0* & + & Hr3(-1,0,0) + 8.D0*Hr3(-1,0,0)*x - 128.D0/3.D0*Hr3(-1,0,0)* & + & x**2 - 128.D0/3.D0*Hr3(-1,0,0)*dx - 32.D0*Hr3(-1,0,1) - 32.D0 & + & *Hr3(-1,0,1)*x - 64.D0/3.D0*Hr3(-1,0,1)*x**2 - 64.D0/3.D0* & + & Hr3(-1,0,1)*dx - 24.D0*Hr3(0,-1,0) + 104.D0*Hr3(0,-1,0)*x - & + & 64.D0*Hr3(0,-1,0)*x**2 - 232.D0/3.D0*Hr3(0,0,0) + 248.D0/3.D0 & + & *Hr3(0,0,0)*x ) + gqqps2 = gqqps2 + nf*cf*ca * ( 236.D0/3.D0*Hr3(0,0,1) + 284.D0/3.D& + & 0*Hr3(0,0,1)*x + 32.D0/3.D0*Hr3(0,0,1)*x**2 + 16.D0*Hr3(0,1,0 & + & ) + 40.D0*Hr3(0,1,0)*x + 32.D0/3.D0*Hr3(0,1,0)*x**2 - 88.D0/3.& + & D0*Hr3(0,1,1) - 136.D0/3.D0*Hr3(0,1,1)*x - 32.D0/3.D0*Hr3(0,1 & + & ,1)*x**2 + 32.D0/3.D0*Hr3(0,1,1)*dx - 36.D0*Hr3(1,0,0) + 36.D0& + & *Hr3(1,0,0)*x + 32.D0*Hr3(1,0,0)*x**2 - 32.D0*Hr3(1,0,0)*dx & + & + 16.D0*Hr3(1,1,0) - 16.D0*Hr3(1,1,0)*x - 64.D0/3.D0*Hr3(1,1 & + & ,0)*x**2 + 64.D0/3.D0*Hr3(1,1,0)*dx + 16.D0*Hr3(1,1,1) - 16.D0& + & *Hr3(1,1,1)*x - 64.D0/3.D0*Hr3(1,1,1)*x**2 + 64.D0/3.D0*Hr3(1 & + & ,1,1)*dx + 32.D0*Hr4(0,-1,-1,0) - 32.D0*Hr4(0,-1,-1,0)*x + 48.& + & D0*Hr4(0,-1,0,0) - 48.D0*Hr4(0,-1,0,0)*x + 80.D0*Hr4(0,0,-1,0 & + & ) - 16.D0*Hr4(0,0,-1,0)*x + 64.D0*Hr4(0,0,0,0) - 48.D0*Hr4(0, & + & 0,0,0)*x - 8.D0*Hr4(0,0,0,1) - 8.D0*Hr4(0,0,0,1)*x + 16.D0* & + & Hr4(0,0,1,1) + 16.D0*Hr4(0,0,1,1)*x - 56.D0*Hr4(0,1,0,0) - 56.& + & D0*Hr4(0,1,0,0)*x + 32.D0*Hr4(0,1,1,0) + 32.D0*Hr4(0,1,1,0)*x & + & + 32.D0*Hr4(0,1,1,1) ) + gqqps2 = gqqps2 + nf*cf*ca * ( 32.D0*Hr4(0,1,1,1)*x ) + gqqps2 = gqqps2 + nf*cf**2 * ( 2530.D0/27.D0 + 3338.D0/27.D0*x - & + & 872.D0/3.D0*x**2 + 220.D0/3.D0*dx + 160.D0*z3*x + 256.D0/3.D0 & + & *z3*x**2 - 64.D0*z3*dx + 272.D0*z2 + 20.D0*z2*x + 448.D0/9.D0 & + & *z2*x**2 - 296.D0/5.D0*z2**2 - 296.D0/5.D0*z2**2*x + 1510.D0/ & + & 9.D0*Hr1(0) + 5486.D0/9.D0*Hr1(0)*x - 104.D0/27.D0*Hr1(0)* & + & x**2 - 112.D0*Hr1(0)*z3 - 112.D0*Hr1(0)*z3*x + 32.D0*Hr1(0)* & + & z2 - 48.D0*Hr1(0)*z2*x - 256.D0/3.D0*Hr1(0)*z2*x**2 - 664.D0/ & + & 3.D0*Hr1(1) + 1004.D0/3.D0*Hr1(1)*x - 968.D0/27.D0*Hr1(1)* & + & x**2 - 2092.D0/27.D0*Hr1(1)*dx - 512.D0/3.D0*Hr2(0,0) + 212.D0& + & /3.D0*Hr2(0,0)*x - 352.D0/3.D0*Hr2(0,0)*x**2 + 96.D0*Hr2(0,0) & + & *z2 + 96.D0*Hr2(0,0)*z2*x - 272.D0*Hr2(0,1) - 20.D0*Hr2(0,1)* & + & x - 448.D0/9.D0*Hr2(0,1)*x**2 - 128.D0/3.D0*Hr2(1,0) + 272.D0/& + & 3.D0*Hr2(1,0)*x - 800.D0/9.D0*Hr2(1,0)*x**2 + 368.D0/9.D0* & + & Hr2(1,0)*dx + 28.D0/3.D0*Hr2(1,1) - 28.D0/3.D0*Hr2(1,1)*x - & + & 64.D0/3.D0*Hr2(1,1)*x**2 + 64.D0/3.D0*Hr2(1,1)*dx + 24.D0* & + & Hr3(0,0,0) ) + gqqps2 = gqqps2 + nf*cf**2 * ( 40.D0*Hr3(0,0,0)*x + 352.D0/3.D0* & + & Hr3(0,0,0)*x**2 - 32.D0*Hr3(0,0,1) + 48.D0*Hr3(0,0,1)*x + 256.& + & D0/3.D0*Hr3(0,0,1)*x**2 + 32.D0*Hr3(0,1,0) + 112.D0*Hr3(0,1,0 & + & )*x + 64.D0*Hr3(0,1,0)*x**2 + 48.D0*Hr3(0,1,1) + 64.D0*Hr3(0, & + & 1,1)*x + 64.D0/3.D0*Hr3(0,1,1)*x**2 + 8.D0*Hr3(1,0,0) - 8.D0* & + & Hr3(1,0,0)*x - 32.D0/3.D0*Hr3(1,0,0)*x**2 + 32.D0/3.D0*Hr3(1, & + & 0,0)*dx - 16.D0*Hr3(1,1,0) + 16.D0*Hr3(1,1,0)*x + 64.D0/3.D0* & + & Hr3(1,1,0)*x**2 - 64.D0/3.D0*Hr3(1,1,0)*dx - 16.D0*Hr3(1,1,1) & + & + 16.D0*Hr3(1,1,1)*x + 64.D0/3.D0*Hr3(1,1,1)*x**2 - 64.D0/3.D& + & 0*Hr3(1,1,1)*dx - 64.D0*Hr4(0,0,0,0) - 64.D0*Hr4(0,0,0,0)*x & + & - 96.D0*Hr4(0,0,0,1) - 96.D0*Hr4(0,0,0,1)*x - 64.D0*Hr4(0,0, & + & 1,0) - 64.D0*Hr4(0,0,1,0)*x - 16.D0*Hr4(0,0,1,1) - 16.D0*Hr4( & + & 0,0,1,1)*x + 16.D0*Hr4(0,1,0,0) + 16.D0*Hr4(0,1,0,0)*x - 32.D0& + & *Hr4(0,1,1,0) - 32.D0*Hr4(0,1,1,0)*x - 32.D0*Hr4(0,1,1,1) - & + & 32.D0*Hr4(0,1,1,1)*x ) + gqqps2 = gqqps2 + nf2*cf * ( 616.D0/27.D0 - 1480.D0/27.D0*x + & + & 800.D0/27.D0*x**2 + 64.D0/27.D0*dx + 16.D0/3.D0*z3 + 16.D0/3.D& + & 0*z3*x + 80.D0/9.D0*z2 - 64.D0/9.D0*z2*x - 32.D0/3.D0*z2*x**2 & + & + 592.D0/27.D0*Hr1(0) - 560.D0/27.D0*Hr1(0)*x - 304.D0/9.D0* & + & Hr1(0)*x**2 + 32.D0/3.D0*Hr1(0)*z2 + 32.D0/3.D0*Hr1(0)*z2*x & + & - 56.D0/3.D0*Hr1(1) + 104.D0/3.D0*Hr1(1)*x - 592.D0/27.D0* & + & Hr1(1)*x**2 + 160.D0/27.D0*Hr1(1)*dx + 232.D0/9.D0*Hr2(0,0) & + & + 232.D0/9.D0*Hr2(0,0)*x - 80.D0/9.D0*Hr2(0,1) + 64.D0/9.D0* & + & Hr2(0,1)*x + 32.D0/3.D0*Hr2(0,1)*x**2 + 8.D0/3.D0*Hr2(1,1) - & + & 8.D0/3.D0*Hr2(1,1)*x - 32.D0/9.D0*Hr2(1,1)*x**2 + 32.D0/9.D0* & + & Hr2(1,1)*dx + 16.D0/3.D0*Hr3(0,0,0) + 16.D0/3.D0*Hr3(0,0,0)*x & + & - 32.D0/3.D0*Hr3(0,0,1) - 32.D0/3.D0*Hr3(0,0,1)*x + 16.D0/3.D& + & 0*Hr3(0,1,1) + 16.D0/3.D0*Hr3(0,1,1)*x ) +! + X2PSA = GQQPS2 +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The gluon->quark splitting functions P_qg^(2). +! + FUNCTION X2QGA (X, NF) +! + IMPLICIT REAL*8 (A - Z) + COMPLEX*16 HC1, HC2, HC3, HC4 + INTEGER NF, NF2, N1, N2, NW, I1, I2, I3, N + PARAMETER ( N1 = -1, N2 = 1, NW = 4 ) + DIMENSION HC1(N1:N2),HC2(N1:N2,N1:N2),HC3(N1:N2,N1:N2,N1:N2), & + & HC4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HR1(N1:N2),HR2(N1:N2,N1:N2),HR3(N1:N2,N1:N2,N1:N2), & + & HR4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HI1(N1:N2),HI2(N1:N2,N1:N2),HI3(N1:N2,N1:N2,N1:N2), & + & HI4(N1:N2,N1:N2,N1:N2,N1:N2) + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0 ) +! +! ...Colour factors and an abbreviation +! + !CF = 4./3.D0 + !CA = 3.D0 + NF2 = NF*NF +! + DX = 1.D0/X +! +! ...The harmonic polylogs up to weight 4 by Gehrmann and Remiddi +! + CALL HPLOG (X, NW, HC1,HC2,HC3,HC4, HR1,HR2,HR3,HR4, & + & HI1,HI2,HI3,HI4, N1, N2) +! +! ...The splitting function in terms of the harmonic polylogs +! + gqg2 = & + & + nf*ca**2 * ( 10454.D0/27.D0 - 102608.D0/27.D0*x + 103040.D0/ & + & 27.D0*x**2 - 9404.D0/27.D0*dx + 48.D0*z3 + 1000.D0*z3*x - & + & 2768.D0/3.D0*z3*x**2 + 96.D0*z3*dx - 628.D0/3.D0*z2 + 2096.D0/& + & 9.D0*z2*x - 620.D0/9.D0*z2*x**2 + 512.D0/9.D0*z2*dx + 538.D0/ & + & 5.D0*z2**2 + 396.D0*z2**2*x + 224.D0/5.D0*z2**2*x**2 - 40.D0* & + & Hr1(-1)*z3 - 80.D0*Hr1(-1)*z3*x - 80.D0*Hr1(-1)*z3*x**2 + 120.& + & D0*Hr1(-1)*z2 + 88.D0*Hr1(-1)*z2*x - 64.D0/3.D0*Hr1(-1)*z2* & + & x**2 + 32.D0/3.D0*Hr1(-1)*z2*dx - 8696.D0/27.D0*Hr1(0) - & + & 30962.D0/27.D0*Hr1(0)*x - 3040.D0*Hr1(0)*x**2 - 896.D0/27.D0* & + & Hr1(0)*dx + 192.D0*Hr1(0)*z3 + 576.D0*Hr1(0)*z3*x - 44.D0* & + & Hr1(0)*z2 + 108.D0*Hr1(0)*z2*x - 248.D0/3.D0*Hr1(0)*z2*x**2 & + & + 8288.D0/27.D0*Hr1(1) - 7750.D0/27.D0*Hr1(1)*x - 1520.D0/27.& + & D0*Hr1(1)*x**2 + 644.D0/9.D0*Hr1(1)*dx - 248.D0*Hr1(1)*z3 + & + & 496.D0*Hr1(1)*z3*x - 496.D0*Hr1(1)*z3*x**2 + 212.D0/3.D0*Hr1( & + & 1)*z2 - 64.D0/3.D0*Hr1(1)*z2*x - 136.D0/3.D0*Hr1(1)*z2*x**2 & + & + 32.D0/3.D0*Hr1(1)*z2*dx ) + gqg2 = gqg2 + nf*ca**2 * ( 16.D0*Hr2(-1,-1)*z2 + 32.D0*Hr2(-1,-1) & + & *z2*x + 32.D0*Hr2(-1,-1)*z2*x**2 - 704.D0/9.D0*Hr2(-1,0) + & + & 5864.D0/9.D0*Hr2(-1,0)*x + 2216.D0/3.D0*Hr2(-1,0)*x**2 + 832.D& + & 0/9.D0*Hr2(-1,0)*dx + 56.D0*Hr2(0,-1)*z2 - 16.D0*Hr2(0,-1)*z2 & + & *x + 64.D0*Hr2(0,-1)*z2*x**2 + 2396.D0/9.D0*Hr2(0,0) + 200.D0 & + & *Hr2(0,0)*x + 10244.D0/9.D0*Hr2(0,0)*x**2 - 12.D0*Hr2(0,0)*z2 & + & + 56.D0*Hr2(0,0)*z2*x - 96.D0*Hr2(0,0)*z2*x**2 + 628.D0/3.D0 & + & *Hr2(0,1) + 1256.D0/3.D0*Hr2(0,1)*x + 620.D0/9.D0*Hr2(0,1)* & + & x**2 + 320.D0/9.D0*Hr2(0,1)*dx + 24.D0*Hr2(0,1)*z2 + 80.D0* & + & Hr2(0,1)*z2*x + 92.D0/3.D0*Hr2(1,0) + 688.D0/3.D0*Hr2(1,0)*x & + & - 276.D0*Hr2(1,0)*x**2 + 24.D0*Hr2(1,0)*dx - 80.D0*Hr2(1,0)* & + & z2 + 160.D0*Hr2(1,0)*z2*x - 160.D0*Hr2(1,0)*z2*x**2 - 164.D0/ & + & 9.D0*Hr2(1,1) - 1904.D0/9.D0*Hr2(1,1)*x + 188.D0*Hr2(1,1)* & + & x**2 - 160.D0/9.D0*Hr2(1,1)*dx - 16.D0*Hr2(1,1)*z2 + 32.D0* & + & Hr2(1,1)*z2*x - 32.D0*Hr2(1,1)*z2*x**2 + 112.D0*Hr3(-1,-1,0) & + & - 80.D0*Hr3(-1,-1,0)*x ) + gqg2 = gqg2 + nf*ca**2 * ( - 640.D0/3.D0*Hr3(-1,-1,0)*x**2 - 64.D& + & 0/3.D0*Hr3(-1,-1,0)*dx - 256.D0/3.D0*Hr3(-1,0,0) - 1016.D0/3.D& + & 0*Hr3(-1,0,0)*x - 976.D0/3.D0*Hr3(-1,0,0)*x**2 - 128.D0/3.D0* & + & Hr3(-1,0,0)*dx - 64.D0*Hr3(-1,0,1) - 128.D0*Hr3(-1,0,1)*x - & + & 256.D0/3.D0*Hr3(-1,0,1)*x**2 - 64.D0/3.D0*Hr3(-1,0,1)*dx - 72.& + & D0*Hr3(0,-1,0) + 216.D0*Hr3(0,-1,0)*x - 400.D0*Hr3(0,-1,0)* & + & x**2 - 56.D0/3.D0*Hr3(0,0,0) + 56.D0/3.D0*Hr3(0,0,0)*x + 96.D0& + & *Hr3(0,0,0)*x**2 + 44.D0*Hr3(0,0,1) + 108.D0*Hr3(0,0,1)*x + & + & 248.D0/3.D0*Hr3(0,0,1)*x**2 + 16.D0*Hr3(0,1,0) + 96.D0*Hr3(0, & + & 1,0)*x - 40.D0/3.D0*Hr3(0,1,0)*x**2 - 32.D0*Hr3(0,1,1)*x - & + & 848.D0/3.D0*Hr3(0,1,1)*x**2 + 32.D0/3.D0*Hr3(0,1,1)*dx - 304.D& + & 0/3.D0*Hr3(1,0,0) - 148.D0/3.D0*Hr3(1,0,0)*x + 592.D0/3.D0* & + & Hr3(1,0,0)*x**2 - 32.D0*Hr3(1,0,0)*dx - 44.D0/3.D0*Hr3(1,0,1) & + & + 184.D0/3.D0*Hr3(1,0,1)*x - 184.D0/3.D0*Hr3(1,0,1)*x**2 + & + & 92.D0/3.D0*Hr3(1,1,0) + 392.D0/3.D0*Hr3(1,1,0)*x - 168.D0* & + & Hr3(1,1,0)*x**2 ) + gqg2 = gqg2 + nf*ca**2 * ( 64.D0/3.D0*Hr3(1,1,0)*dx + 68.D0/3.D0* & + & Hr3(1,1,1) - 184.D0/3.D0*Hr3(1,1,1)*x + 128.D0/3.D0*Hr3(1,1,1 & + & )*x**2 + 32.D0/3.D0*Hr3(1,1,1)*dx + 96.D0*Hr4(-1,-1,-1,0) + & + & 192.D0*Hr4(-1,-1,-1,0)*x + 192.D0*Hr4(-1,-1,-1,0)*x**2 + 32.D0& + & *Hr4(-1,-1,0,0) + 64.D0*Hr4(-1,-1,0,0)*x + 64.D0*Hr4(-1,-1,0, & + & 0)*x**2 + 32.D0*Hr4(-1,-1,0,1) + 64.D0*Hr4(-1,-1,0,1)*x + 64.D& + & 0*Hr4(-1,-1,0,1)*x**2 - 16.D0*Hr4(-1,0,-1,0) - 32.D0*Hr4(-1,0 & + & ,-1,0)*x - 32.D0*Hr4(-1,0,-1,0)*x**2 - 24.D0*Hr4(-1,0,0,0) - & + & 48.D0*Hr4(-1,0,0,0)*x - 48.D0*Hr4(-1,0,0,0)*x**2 - 32.D0*Hr4( & + & -1,0,0,1) - 64.D0*Hr4(-1,0,0,1)*x - 64.D0*Hr4(-1,0,0,1)*x**2 & + & + 32.D0*Hr4(-1,0,1,1) + 64.D0*Hr4(-1,0,1,1)*x + 64.D0*Hr4(-1 & + & ,0,1,1)*x**2 + 48.D0*Hr4(0,-1,-1,0) - 160.D0*Hr4(0,-1,-1,0)*x & + & + 24.D0*Hr4(0,-1,0,0) - 208.D0*Hr4(0,-1,0,0)*x - 32.D0*Hr4(0 & + & ,-1,0,0)*x**2 - 32.D0*Hr4(0,-1,0,1) - 64.D0*Hr4(0,-1,0,1)*x & + & - 64.D0*Hr4(0,-1,0,1)*x**2 + 72.D0*Hr4(0,0,-1,0) - 16.D0* & + & Hr4(0,0,-1,0)*x ) + gqg2 = gqg2 + nf*ca**2 * ( 64.D0*Hr4(0,0,0,0) - 240.D0*Hr4(0,0,0, & + & 0)*x + 12.D0*Hr4(0,0,0,1) - 72.D0*Hr4(0,0,0,1)*x + 96.D0*Hr4( & + & 0,0,0,1)*x**2 + 48.D0*Hr4(0,0,1,1) + 128.D0*Hr4(0,0,1,1)*x - & + & 84.D0*Hr4(0,1,0,0) - 200.D0*Hr4(0,1,0,0)*x - 64.D0*Hr4(0,1,0, & + & 0)*x**2 + 32.D0*Hr4(0,1,1,0) + 128.D0*Hr4(0,1,1,0)*x + 16.D0* & + & Hr4(0,1,1,1) + 64.D0*Hr4(0,1,1,1)*x - 48.D0*Hr4(1,0,-1,0) + & + & 96.D0*Hr4(1,0,-1,0)*x - 96.D0*Hr4(1,0,-1,0)*x**2 + 40.D0*Hr4( & + & 1,0,0,0) - 80.D0*Hr4(1,0,0,0)*x + 80.D0*Hr4(1,0,0,0)*x**2 + & + & 48.D0*Hr4(1,0,0,1) - 96.D0*Hr4(1,0,0,1)*x + 96.D0*Hr4(1,0,0,1 & + & )*x**2 - 32.D0*Hr4(1,0,1,0) + 64.D0*Hr4(1,0,1,0)*x - 64.D0* & + & Hr4(1,0,1,0)*x**2 - 16.D0*Hr4(1,1,0,0) + 32.D0*Hr4(1,1,0,0)*x & + & - 32.D0*Hr4(1,1,0,0)*x**2 - 32.D0*Hr4(1,1,0,1) + 64.D0*Hr4(1 & + & ,1,0,1)*x - 64.D0*Hr4(1,1,0,1)*x**2 - 64.D0*Hr4(1,1,1,0) + & + & 128.D0*Hr4(1,1,1,0)*x - 128.D0*Hr4(1,1,1,0)*x**2 + 32.D0*Hr4( & + & 1,1,1,1) - 64.D0*Hr4(1,1,1,1)*x + 64.D0*Hr4(1,1,1,1)*x**2 ) + gqg2 = gqg2 + nf*cf*ca * ( 1429.D0/12.D0 + 2303.D0/2.D0*x - 3997.D& + & 0/3.D0*x**2 + 220.D0/3.D0*dx - 100.D0/3.D0*z3 - 1792.D0/3.D0* & + & z3*x + 2240.D0/3.D0*z3*x**2 - 64.D0*z3*dx + 688.D0/9.D0*z2 + & + & 268.D0/9.D0*z2*x + 392.D0*z2*x**2 - 292.D0/5.D0*z2**2 - 808.D0& + & /5.D0*z2**2*x - 32.D0*z2**2*x**2 + 136.D0*Hr1(-1)*z3 + 272.D0 & + & *Hr1(-1)*z3*x + 272.D0*Hr1(-1)*z3*x**2 + 40.D0*Hr1(-1)*z2 + & + & 80.D0*Hr1(-1)*z2*x + 40.D0*Hr1(-1)*z2*x**2 + 2696.D0/27.D0* & + & Hr1(0) + 24569.D0/27.D0*Hr1(0)*x + 11332.D0/27.D0*Hr1(0)*x**2 & + & - 88.D0*Hr1(0)*z3 - 656.D0*Hr1(0)*z3*x + 32.D0*Hr1(0)*z3* & + & x**2 - 40.D0*Hr1(0)*z2 - 360.D0*Hr1(0)*z2*x - 1384.D0/3.D0* & + & Hr1(0)*z2*x**2 - 3692.D0/27.D0*Hr1(1) + 12892.D0/27.D0*Hr1(1) & + & *x - 9620.D0/27.D0*Hr1(1)*x**2 - 1484.D0/27.D0*Hr1(1)*dx + & + & 312.D0*Hr1(1)*z3 - 624.D0*Hr1(1)*z3*x + 624.D0*Hr1(1)*z3*x**2 & + & - 52.D0*Hr1(1)*z2 - 40.D0*Hr1(1)*z2*x + 80.D0*Hr1(1)*z2*x**2 & + & - 144.D0*Hr2(-1,-1)*z2 - 288.D0*Hr2(-1,-1)*z2*x - 288.D0* & + & Hr2(-1,-1)*z2*x**2 ) + gqg2 = gqg2 + nf*cf*ca * ( 296.D0*Hr2(-1,0) + 152.D0*Hr2(-1,0)*x & + & - 144.D0*Hr2(-1,0)*x**2 + 144.D0*Hr2(-1,0)*z2 + 288.D0*Hr2( & + & -1,0)*z2*x + 288.D0*Hr2(-1,0)*z2*x**2 + 112.D0*Hr2(0,-1)*z2 & + & + 128.D0*Hr2(0,-1)*z2*x + 288.D0*Hr2(0,-1)*z2*x**2 - 1267.D0/& + & 9.D0*Hr2(0,0) - 3190.D0/9.D0*Hr2(0,0)*x - 2204.D0/9.D0*Hr2(0, & + & 0)*x**2 + 96.D0*Hr2(0,0)*z2 + 96.D0*Hr2(0,0)*z2*x + 64.D0* & + & Hr2(0,0)*z2*x**2 - 688.D0/9.D0*Hr2(0,1) + 1100.D0/9.D0*Hr2(0, & + & 1)*x - 392.D0*Hr2(0,1)*x**2 + 16.D0*Hr2(0,1)*z2 - 64.D0*Hr2(0 & + & ,1)*z2*x + 128.D0*Hr2(0,1)*z2*x**2 - 116.D0/9.D0*Hr2(1,0) + & + & 1888.D0/9.D0*Hr2(1,0)*x - 212.D0*Hr2(1,0)*x**2 + 368.D0/9.D0* & + & Hr2(1,0)*dx + 144.D0*Hr2(1,0)*z2 - 288.D0*Hr2(1,0)*z2*x + 288.& + & D0*Hr2(1,0)*z2*x**2 - 808.D0/9.D0*Hr2(1,1) + 4568.D0/9.D0* & + & Hr2(1,1)*x - 4096.D0/9.D0*Hr2(1,1)*x**2 + 368.D0/9.D0*Hr2(1,1 & + & )*dx + 96.D0*Hr2(1,1)*z2 - 192.D0*Hr2(1,1)*z2*x + 192.D0*Hr2( & + & 1,1)*z2*x**2 - 144.D0*Hr3(-1,-1,0) - 224.D0*Hr3(-1,-1,0)*x - & + & 80.D0*Hr3(-1,-1,0)*x**2 ) + gqg2 = gqg2 + nf*cf*ca * ( 40.D0*Hr3(-1,0,0) + 64.D0*Hr3(-1,0,0)* & + & x + 48.D0*Hr3(-1,0,0)*x**2 - 112.D0*Hr3(-1,0,1) - 192.D0*Hr3( & + & -1,0,1)*x - 80.D0*Hr3(-1,0,1)*x**2 + 208.D0*Hr3(0,-1,0) - 64.D& + & 0*Hr3(0,-1,0)*x + 80.D0*Hr3(0,-1,0)*x**2 + 44.D0/3.D0*Hr3(0,0 & + & ,0) + 344.D0/3.D0*Hr3(0,0,0)*x + 1264.D0/3.D0*Hr3(0,0,0)*x**2 & + & + 40.D0*Hr3(0,0,1) + 296.D0*Hr3(0,0,1)*x + 1384.D0/3.D0*Hr3( & + & 0,0,1)*x**2 + 32.D0*Hr3(0,1,0) + 72.D0*Hr3(0,1,0)*x + 392.D0* & + & Hr3(0,1,0)*x**2 - 44.D0/3.D0*Hr3(0,1,1) + 496.D0/3.D0*Hr3(0,1 & + & ,1)*x + 192.D0*Hr3(0,1,1)*x**2 + 472.D0/3.D0*Hr3(1,0,0) - 488.& + & D0/3.D0*Hr3(1,0,0)*x + 32.D0/3.D0*Hr3(1,0,0)*dx - 20.D0*Hr3(1 & + & ,0,1) + 152.D0*Hr3(1,0,1)*x - 120.D0*Hr3(1,0,1)*x**2 + 4.D0* & + & Hr3(1,1,0) - 88.D0*Hr3(1,1,0)*x + 280.D0/3.D0*Hr3(1,1,0)*x**2 & + & - 64.D0/3.D0*Hr3(1,1,0)*dx - 56.D0/3.D0*Hr3(1,1,1) + 424.D0/ & + & 3.D0*Hr3(1,1,1)*x - 416.D0/3.D0*Hr3(1,1,1)*x**2 - 32.D0/3.D0* & + & Hr3(1,1,1)*dx - 96.D0*Hr4(-1,-1,-1,0) - 192.D0*Hr4(-1,-1,-1,0 & + & )*x ) + gqg2 = gqg2 + nf*cf*ca * ( - 192.D0*Hr4(-1,-1,-1,0)*x**2 + 96.D0 & + & *Hr4(-1,-1,0,0) + 192.D0*Hr4(-1,-1,0,0)*x + 192.D0*Hr4(-1,-1, & + & 0,0)*x**2 + 96.D0*Hr4(-1,-1,0,1) + 192.D0*Hr4(-1,-1,0,1)*x + & + & 192.D0*Hr4(-1,-1,0,1)*x**2 + 48.D0*Hr4(-1,0,-1,0) + 96.D0* & + & Hr4(-1,0,-1,0)*x + 96.D0*Hr4(-1,0,-1,0)*x**2 - 88.D0*Hr4(-1,0 & + & ,0,0) - 176.D0*Hr4(-1,0,0,0)*x - 176.D0*Hr4(-1,0,0,0)*x**2 - & + & 96.D0*Hr4(-1,0,0,1) - 192.D0*Hr4(-1,0,0,1)*x - 192.D0*Hr4(-1, & + & 0,0,1)*x**2 - 32.D0*Hr4(-1,0,1,0) - 64.D0*Hr4(-1,0,1,0)*x - & + & 64.D0*Hr4(-1,0,1,0)*x**2 - 32.D0*Hr4(-1,0,1,1) - 64.D0*Hr4(-1 & + & ,0,1,1)*x - 64.D0*Hr4(-1,0,1,1)*x**2 + 32.D0*Hr4(0,-1,-1,0) & + & + 128.D0*Hr4(0,-1,-1,0)*x + 192.D0*Hr4(0,-1,-1,0)*x**2 - 64.D& + & 0*Hr4(0,-1,0,0) - 96.D0*Hr4(0,-1,0,0)*x - 192.D0*Hr4(0,-1,0,0 & + & )*x**2 - 96.D0*Hr4(0,-1,0,1) - 64.D0*Hr4(0,-1,0,1)*x - 192.D0 & + & *Hr4(0,-1,0,1)*x**2 + 48.D0*Hr4(0,0,-1,0) - 32.D0*Hr4(0,0,-1, & + & 0)*x - 32.D0*Hr4(0,0,0,0) - 64.D0*Hr4(0,0,0,0)*x - 96.D0*Hr4( & + & 0,0,0,1) ) + gqg2 = gqg2 + nf*cf*ca * ( - 128.D0*Hr4(0,0,0,1)*x - 64.D0*Hr4(0 & + & ,0,0,1)*x**2 - 64.D0*Hr4(0,0,1,0) - 192.D0*Hr4(0,0,1,0)*x - & + & 64.D0*Hr4(0,0,1,1) - 96.D0*Hr4(0,0,1,1)*x - 64.D0*Hr4(0,0,1,1 & + & )*x**2 + 88.D0*Hr4(0,1,0,0) + 16.D0*Hr4(0,1,0,0)*x + 96.D0* & + & Hr4(0,1,0,0)*x**2 - 32.D0*Hr4(0,1,0,1)*x**2 - 192.D0*Hr4(0,1, & + & 1,0)*x + 96.D0*Hr4(0,1,1,0)*x**2 - 56.D0*Hr4(0,1,1,1) + 16.D0 & + & *Hr4(0,1,1,1)*x - 64.D0*Hr4(0,1,1,1)*x**2 + 48.D0*Hr4(1,0,-1, & + & 0) - 96.D0*Hr4(1,0,-1,0)*x + 96.D0*Hr4(1,0,-1,0)*x**2 - 24.D0 & + & *Hr4(1,0,0,0) + 48.D0*Hr4(1,0,0,0)*x - 48.D0*Hr4(1,0,0,0)* & + & x**2 - 96.D0*Hr4(1,0,0,1) + 192.D0*Hr4(1,0,0,1)*x - 192.D0* & + & Hr4(1,0,0,1)*x**2 - 96.D0*Hr4(1,0,1,1) + 192.D0*Hr4(1,0,1,1)* & + & x - 192.D0*Hr4(1,0,1,1)*x**2 + 16.D0*Hr4(1,1,0,0) - 32.D0* & + & Hr4(1,1,0,0)*x + 32.D0*Hr4(1,1,0,0)*x**2 - 48.D0*Hr4(1,1,0,1) & + & + 96.D0*Hr4(1,1,0,1)*x - 96.D0*Hr4(1,1,0,1)*x**2 + 48.D0* & + & Hr4(1,1,1,0) - 96.D0*Hr4(1,1,1,0)*x + 96.D0*Hr4(1,1,1,0)*x**2 & + & - 64.D0*Hr4(1,1,1,1) ) + gqg2 = gqg2 + nf*cf*ca * ( 128.D0*Hr4(1,1,1,1)*x - 128.D0*Hr4(1,1 & + & ,1,1)*x**2 ) + gqg2 = gqg2 + nf*cf**2 * ( 963.D0/4.D0 - 641.D0/2.D0*x + 81.D0* & + & x**2 - 24.D0*z3 + 136.D0*z3*x - 304.D0*z3*x**2 - 68.D0*z2 + & + & 48.D0*z2*x - 244.D0*z2*x**2 + 32.D0*z2**2 - 192.D0/5.D0*z2**2 & + & *x + 352.D0/5.D0*z2**2*x**2 + 64.D0*Hr1(-1)*z2 + 128.D0*Hr1( & + & -1)*z2*x + 64.D0*Hr1(-1)*z2*x**2 + 170.D0*Hr1(0) + 57.D0*Hr1( & + & 0)*x + 348.D0*Hr1(0)*x**2 - 56.D0*Hr1(0)*z3 + 208.D0*Hr1(0)* & + & z3*x - 224.D0*Hr1(0)*z3*x**2 - 36.D0*Hr1(0)*z2 + 128.D0*Hr1(0 & + & )*z2*x - 176.D0*Hr1(0)*z2*x**2 - 32.D0*Hr1(1) - 282.D0*Hr1(1) & + & *x + 348.D0*Hr1(1)*x**2 - 112.D0*Hr1(1)*z3 + 224.D0*Hr1(1)*z3 & + & *x - 224.D0*Hr1(1)*z3*x**2 + 32.D0*Hr1(1)*z2 + 80.D0*Hr1(1)* & + & z2*x - 112.D0*Hr1(1)*z2*x**2 - 320.D0*Hr2(-1,0) - 368.D0*Hr2( & + & -1,0)*x - 80.D0*Hr2(-1,0)*x**2 + 32.D0*Hr2(0,-1)*z2 + 89.D0* & + & Hr2(0,0) + 126.D0*Hr2(0,0)*x + 352.D0*Hr2(0,0)*x**2 - 56.D0* & + & Hr2(0,0)*z2 + 112.D0*Hr2(0,0)*z2*x - 224.D0*Hr2(0,0)*z2*x**2 & + & + 68.D0*Hr2(0,1) - 416.D0*Hr2(0,1)*x + 244.D0*Hr2(0,1)*x**2 & + & - 32.D0*Hr2(0,1)*z2 ) + gqg2 = gqg2 + nf*cf**2 * ( 128.D0*Hr2(0,1)*z2*x - 160.D0*Hr2(0,1) & + & *z2*x**2 + 160.D0*Hr2(1,0) - 352.D0*Hr2(1,0)*x + 272.D0*Hr2(1 & + & ,0)*x**2 - 112.D0*Hr2(1,0)*z2 + 224.D0*Hr2(1,0)*z2*x - 224.D0 & + & *Hr2(1,0)*z2*x**2 + 108.D0*Hr2(1,1) - 296.D0*Hr2(1,1)*x + 244.& + & D0*Hr2(1,1)*x**2 - 80.D0*Hr2(1,1)*z2 + 160.D0*Hr2(1,1)*z2*x & + & - 160.D0*Hr2(1,1)*z2*x**2 + 128.D0*Hr3(-1,-1,0) + 256.D0* & + & Hr3(-1,-1,0)*x + 128.D0*Hr3(-1,-1,0)*x**2 - 128.D0*Hr3(-1,0,0 & + & ) - 288.D0*Hr3(-1,0,0)*x - 160.D0*Hr3(-1,0,0)*x**2 - 176.D0* & + & Hr3(0,-1,0) - 32.D0*Hr3(0,-1,0)*x - 128.D0*Hr3(0,-1,0)*x**2 & + & + 12.D0*Hr3(0,0,0) + 64.D0*Hr3(0,0,0)*x + 240.D0*Hr3(0,0,0)* & + & x**2 + 36.D0*Hr3(0,0,1) - 160.D0*Hr3(0,0,1)*x + 176.D0*Hr3(0, & + & 0,1)*x**2 + 48.D0*Hr3(0,1,0) - 80.D0*Hr3(0,1,0)*x + 80.D0* & + & Hr3(0,1,0)*x**2 + 36.D0*Hr3(0,1,1) - 104.D0*Hr3(0,1,1)*x + 96.& + & D0*Hr3(0,1,1)*x**2 - 32.D0*Hr3(1,0,0) - 48.D0*Hr3(1,0,0)*x + & + & 80.D0*Hr3(1,0,0)*x**2 + 32.D0*Hr3(1,0,1) - 208.D0*Hr3(1,0,1)* & + & x ) + gqg2 = gqg2 + nf*cf**2 * ( 176.D0*Hr3(1,0,1)*x**2 - 32.D0*Hr3(1,1 & + & ,0) - 48.D0*Hr3(1,1,0)*x + 80.D0*Hr3(1,1,0)*x**2 - 4.D0*Hr3(1 & + & ,1,1) - 80.D0*Hr3(1,1,1)*x + 96.D0*Hr3(1,1,1)*x**2 + 64.D0* & + & Hr4(-1,-1,0,0) + 128.D0*Hr4(-1,-1,0,0)*x + 128.D0*Hr4(-1,-1,0 & + & ,0)*x**2 + 32.D0*Hr4(-1,0,-1,0) + 64.D0*Hr4(-1,0,-1,0)*x + 64.& + & D0*Hr4(-1,0,-1,0)*x**2 - 16.D0*Hr4(-1,0,0,0) - 32.D0*Hr4(-1,0 & + & ,0,0)*x - 32.D0*Hr4(-1,0,0,0)*x**2 + 64.D0*Hr4(0,-1,-1,0) - & + & 64.D0*Hr4(0,-1,0,0) - 64.D0*Hr4(0,-1,0,0)*x - 128.D0*Hr4(0,-1 & + & ,0,0)*x**2 - 64.D0*Hr4(0,0,-1,0) - 128.D0*Hr4(0,0,-1,0)*x**2 & + & + 16.D0*Hr4(0,0,0,0) + 128.D0*Hr4(0,0,0,0)*x**2 + 56.D0*Hr4( & + & 0,0,0,1) - 112.D0*Hr4(0,0,0,1)*x + 224.D0*Hr4(0,0,0,1)*x**2 & + & + 64.D0*Hr4(0,0,1,0) - 128.D0*Hr4(0,0,1,0)*x + 192.D0*Hr4(0, & + & 0,1,0)*x**2 + 80.D0*Hr4(0,0,1,1) - 160.D0*Hr4(0,0,1,1)*x + & + & 192.D0*Hr4(0,0,1,1)*x**2 + 16.D0*Hr4(0,1,0,0) - 96.D0*Hr4(0,1 & + & ,0,0)*x + 128.D0*Hr4(0,1,0,0)*x**2 + 64.D0*Hr4(0,1,0,1) - 128.& + & D0*Hr4(0,1,0,1)*x ) + gqg2 = gqg2 + nf*cf**2 * ( 160.D0*Hr4(0,1,0,1)*x**2 + 32.D0*Hr4(0 & + & ,1,1,0) - 64.D0*Hr4(0,1,1,0)*x + 32.D0*Hr4(0,1,1,0)*x**2 + 40.& + & D0*Hr4(0,1,1,1) - 80.D0*Hr4(0,1,1,1)*x + 64.D0*Hr4(0,1,1,1)* & + & x**2 - 32.D0*Hr4(1,0,-1,0) + 64.D0*Hr4(1,0,-1,0)*x - 64.D0* & + & Hr4(1,0,-1,0)*x**2 + 48.D0*Hr4(1,0,0,0) - 96.D0*Hr4(1,0,0,0)* & + & x + 96.D0*Hr4(1,0,0,0)*x**2 + 112.D0*Hr4(1,0,0,1) - 224.D0* & + & Hr4(1,0,0,1)*x + 224.D0*Hr4(1,0,0,1)*x**2 + 96.D0*Hr4(1,0,1,0 & + & ) - 192.D0*Hr4(1,0,1,0)*x + 192.D0*Hr4(1,0,1,0)*x**2 + 96.D0* & + & Hr4(1,0,1,1) - 192.D0*Hr4(1,0,1,1)*x + 192.D0*Hr4(1,0,1,1)* & + & x**2 + 64.D0*Hr4(1,1,0,0) - 128.D0*Hr4(1,1,0,0)*x + 128.D0* & + & Hr4(1,1,0,0)*x**2 + 80.D0*Hr4(1,1,0,1) - 160.D0*Hr4(1,1,0,1)* & + & x + 160.D0*Hr4(1,1,0,1)*x**2 + 16.D0*Hr4(1,1,1,0) - 32.D0* & + & Hr4(1,1,1,0)*x + 32.D0*Hr4(1,1,1,0)*x**2 + 32.D0*Hr4(1,1,1,1) & + & - 64.D0*Hr4(1,1,1,1)*x + 64.D0*Hr4(1,1,1,1)*x**2 ) + gqg2 = gqg2 + nf2*ca * ( 226.D0/27.D0 - 1348.D0/27.D0*x + 2800.D & + & 0/81.D0*x**2 - 424.D0/81.D0*dx - 16.D0*z3*x + 88.D0/9.D0*z2*x & + & - 160.D0/27.D0*Hr1(0) + 560.D0/27.D0*Hr1(0)*x - 1832.D0/27.D0& + & *Hr1(0)*x**2 - 152.D0/27.D0*Hr1(1) + 112.D0/27.D0*Hr1(1)*x - & + & 112.D0/27.D0*Hr1(1)*x**2 - 8.D0/3.D0*Hr1(1)*z2 + 16.D0/3.D0* & + & Hr1(1)*z2*x - 16.D0/3.D0*Hr1(1)*z2*x**2 + 80.D0/9.D0*Hr2(-1,0 & + & ) + 112.D0/9.D0*Hr2(-1,0)*x + 112.D0/9.D0*Hr2(-1,0)*x**2 + 64.& + & D0/9.D0*Hr2(0,0) + 104.D0/3.D0*Hr2(0,0)*x + 64.D0/9.D0*Hr2(0, & + & 0)*x**2 + 8.D0/3.D0*Hr2(0,1)*x + 80.D0/9.D0*Hr2(1,1) - 112.D0/& + & 9.D0*Hr2(1,1)*x + 112.D0/9.D0*Hr2(1,1)*x**2 + 16.D0/3.D0*Hr3( & + & -1,0,0) + 32.D0/3.D0*Hr3(-1,0,0)*x + 32.D0/3.D0*Hr3(-1,0,0)* & + & x**2 - 16.D0/3.D0*Hr3(0,0,0) + 64.D0/3.D0*Hr3(0,0,0)*x - 8.D0/& + & 3.D0*Hr3(1,0,0) + 16.D0/3.D0*Hr3(1,0,0)*x - 16.D0/3.D0*Hr3(1, & + & 0,0)*x**2 + 8.D0/3.D0*Hr3(1,0,1) - 16.D0/3.D0*Hr3(1,0,1)*x + & + & 16.D0/3.D0*Hr3(1,0,1)*x**2 - 8.D0/3.D0*Hr3(1,1,0) + 16.D0/3.D0& + & *Hr3(1,1,0)*x ) + gqg2 = gqg2 + nf2*ca * ( - 16.D0/3.D0*Hr3(1,1,0)*x**2 - 8.D0/3. & + & D0*Hr3(1,1,1) + 16.D0/3.D0*Hr3(1,1,1)*x - 16.D0/3.D0*Hr3(1,1, & + & 1)*x**2 ) + gqg2 = gqg2 + nf2*cf * ( - 13025.D0/54.D0 - 89.D0/27.D0*x + & + & 18424.D0/81.D0*x**2 + 1232.D0/81.D0*dx - 8.D0/3.D0*z3 + 16.D0/& + & 3.D0*z3*x - 16.D0/3.D0*z3*x**2 + 80.D0/9.D0*z2 - 112.D0/9.D0* & + & z2*x + 112.D0/9.D0*z2*x**2 - 4856.D0/27.D0*Hr1(0) - 5270.D0/ & + & 27.D0*Hr1(0)*x - 560.D0/9.D0*Hr1(0)*x**2 + 224.D0/27.D0*Hr1(1 & + & ) - 148.D0/27.D0*Hr1(1)*x + 112.D0/27.D0*Hr1(1)*x**2 - 1370.D0& + & /9.D0*Hr2(0,0) - 884.D0/9.D0*Hr2(0,0)*x - 352.D0/9.D0*Hr2(0,0 & + & )*x**2 - 80.D0/9.D0*Hr2(0,1) + 112.D0/9.D0*Hr2(0,1)*x - 112.D0& + & /9.D0*Hr2(0,1)*x**2 - 40.D0/9.D0*Hr2(1,0) + 128.D0/9.D0*Hr2(1 & + & ,0)*x - 128.D0/9.D0*Hr2(1,0)*x**2 - 80.D0/9.D0*Hr2(1,1) + 112.& + & D0/9.D0*Hr2(1,1)*x - 112.D0/9.D0*Hr2(1,1)*x**2 - 152.D0/3.D0* & + & Hr3(0,0,0) + 160.D0/3.D0*Hr3(0,0,0)*x + 32.D0*Hr3(0,0,0)*x**2 & + & + 8.D0/3.D0*Hr3(0,1,1) - 16.D0/3.D0*Hr3(0,1,1)*x + 16.D0/3.D0& + & *Hr3(0,1,1)*x**2 - 16.D0/3.D0*Hr3(1,0,0) + 32.D0/3.D0*Hr3(1,0 & + & ,0)*x - 32.D0/3.D0*Hr3(1,0,0)*x**2 + 8.D0/3.D0*Hr3(1,1,1) - & + & 16.D0/3.D0*Hr3(1,1,1)*x ) + gqg2 = gqg2 + nf2*cf * ( 16.D0/3.D0*Hr3(1,1,1)*x**2 - 32.D0* & + & Hr4(0,0,0,0) + 64.D0*Hr4(0,0,0,0)*x ) +! + X2QGA = GQG2 +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The quark->gluon splitting functions P_gq^(2). +! + FUNCTION X2GQA (X, NF) +! + IMPLICIT REAL*8 (A - Z) + COMPLEX*16 HC1, HC2, HC3, HC4 + INTEGER NF, NF2, N1, N2, NW, I1, I2, I3, N + PARAMETER ( N1 = -1, N2 = 1, NW = 4 ) + DIMENSION HC1(N1:N2),HC2(N1:N2,N1:N2),HC3(N1:N2,N1:N2,N1:N2), & + & HC4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HR1(N1:N2),HR2(N1:N2,N1:N2),HR3(N1:N2,N1:N2,N1:N2), & + & HR4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HI1(N1:N2),HI2(N1:N2,N1:N2),HI3(N1:N2,N1:N2,N1:N2), & + & HI4(N1:N2,N1:N2,N1:N2,N1:N2) + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0 ) +! +! ...Colour factors and an abbreviation +! + !CF = 4./3.D0 + !CA = 3.D0 + NF2 = NF*NF +! + DX = 1.D0/X +! +! ...The harmonic polylogs up to weight 4 by Gehrmann and Remiddi +! + CALL HPLOG (X, NW, HC1,HC2,HC3,HC4, HR1,HR2,HR3,HR4, & + & HI1,HI2,HI3,HI4, N1, N2) +! +! ...The splitting function in terms of the harmonic polylogs +! + ggq2 = & + & + cf*ca**2 * ( - 12710.D0/9.D0 + 1789.D0/3.D0*x - 33680.D0/81.D& + & 0*x**2 + 138305.D0/81.D0*dx + 1424.D0/3.D0*z3 + 700.D0/3.D0* & + & z3*x + 256.D0/3.D0*z3*x**2 - 336.D0*z3*dx + 568.D0/9.D0*z2 + & + & 568.D0/9.D0*z2*x - 1664.D0/9.D0*z2*x**2 - 872.D0/3.D0*z2*dx & + & - 772.D0/5.D0*z2**2 - 366.D0/5.D0*z2**2*x - 544.D0/5.D0* & + & z2**2*dx - 368.D0*Hr1(-1)*z3 - 184.D0*Hr1(-1)*z3*x - 368.D0* & + & Hr1(-1)*z3*dx - 520.D0/3.D0*Hr1(-1)*z2 - 392.D0/3.D0*Hr1(-1)* & + & z2*x - 32.D0/3.D0*Hr1(-1)*z2*x**2 + 104.D0*Hr1(-1)*z2*dx + & + & 38224.D0/27.D0*Hr1(0) + 3202.D0/27.D0*Hr1(0)*x + 9344.D0/27.D0& + & *Hr1(0)*x**2 + 6320.D0/27.D0*Hr1(0)*dx - 224.D0*Hr1(0)*z3 - & + & 80.D0*Hr1(0)*z3*x - 32.D0*Hr1(0)*z3*dx + 2140.D0/3.D0*Hr1(0)* & + & z2 + 1028.D0/3.D0*Hr1(0)*z2*x + 96.D0*Hr1(0)*z2*x**2 - 176.D0/& + & 3.D0*Hr1(0)*z2*dx + 6260.D0/27.D0*Hr1(1) - 766.D0/27.D0*Hr1(1 & + & )*x - 1744.D0/27.D0*Hr1(1)*x**2 - 13516.D0/27.D0*Hr1(1)*dx - & + & 112.D0*Hr1(1)*z3 + 56.D0*Hr1(1)*z3*x + 112.D0*Hr1(1)*z3*dx - & + & 352.D0/3.D0*Hr1(1)*z2 ) + ggq2 = ggq2 + cf*ca**2 * ( 500.D0/3.D0*Hr1(1)*z2*x + 32.D0/3.D0* & + & Hr1(1)*z2*x**2 - 16.D0/3.D0*Hr1(1)*z2*dx + 416.D0*Hr2(-1,-1)* & + & z2 + 208.D0*Hr2(-1,-1)*z2*x + 416.D0*Hr2(-1,-1)*z2*dx - 920.D0& + & /3.D0*Hr2(-1,0) + 212.D0/3.D0*Hr2(-1,0)*x - 160.D0*Hr2(-1,0)* & + & x**2 - 872.D0/3.D0*Hr2(-1,0)*dx - 320.D0*Hr2(-1,0)*z2 - 160.D0& + & *Hr2(-1,0)*z2*x - 320.D0*Hr2(-1,0)*z2*dx - 432.D0*Hr2(0,-1)* & + & z2 - 56.D0*Hr2(0,-1)*z2*x - 160.D0*Hr2(0,-1)*z2*dx - 5080.D0/ & + & 9.D0*Hr2(0,0) + 392.D0/9.D0*Hr2(0,0)*x - 616.D0/9.D0*Hr2(0,0) & + & *x**2 - 104.D0*Hr2(0,0)*z2 - 92.D0*Hr2(0,0)*z2*x - 568.D0/9.D0& + & *Hr2(0,1) + 68.D0/9.D0*Hr2(0,1)*x + 1664.D0/9.D0*Hr2(0,1)* & + & x**2 - 80.D0*Hr2(0,1)*z2 - 56.D0*Hr2(0,1)*z2*x - 64.D0*Hr2(0, & + & 1)*z2*dx + 1096.D0/9.D0*Hr2(1,0) + 400.D0/9.D0*Hr2(1,0)*x + & + & 1160.D0/9.D0*Hr2(1,0)*x**2 - 284.D0/3.D0*Hr2(1,0)*dx + 64.D0* & + & Hr2(1,0)*z2 - 32.D0*Hr2(1,0)*z2*x - 64.D0*Hr2(1,0)*z2*dx - & + & 100.D0/9.D0*Hr2(1,1) + 914.D0/9.D0*Hr2(1,1)*x + 592.D0/9.D0* & + & Hr2(1,1)*x**2 ) + ggq2 = ggq2 + cf*ca**2 * ( 260.D0/3.D0*Hr2(1,1)*dx + 32.D0*Hr2(1, & + & 1)*z2 - 16.D0*Hr2(1,1)*z2*x - 32.D0*Hr2(1,1)*z2*dx + 176.D0/3.& + & D0*Hr3(-1,-1,0) - 176.D0/3.D0*Hr3(-1,-1,0)*x + 64.D0/3.D0* & + & Hr3(-1,-1,0)*x**2 + 304.D0*Hr3(-1,-1,0)*dx + 1160.D0/3.D0* & + & Hr3(-1,0,0) + 232.D0/3.D0*Hr3(-1,0,0)*x + 128.D0/3.D0*Hr3(-1, & + & 0,0)*x**2 + 784.D0/3.D0*Hr3(-1,0,0)*dx + 608.D0/3.D0*Hr3(-1,0 & + & ,1) + 304.D0/3.D0*Hr3(-1,0,1)*x + 64.D0/3.D0*Hr3(-1,0,1)*x**2 & + & + 48.D0*Hr3(-1,0,1)*dx + 1160.D0/3.D0*Hr3(0,-1,0) + 16.D0* & + & Hr3(0,-1,0)*x + 64.D0*Hr3(0,-1,0)*x**2 - 176.D0/3.D0*Hr3(0,-1 & + & ,0)*dx - 272.D0/3.D0*Hr3(0,0,0) - 224.D0*Hr3(0,0,0)*x - 224.D0& + & /3.D0*Hr3(0,0,0)*x**2 - 2140.D0/3.D0*Hr3(0,0,1) - 980.D0/3.D0 & + & *Hr3(0,0,1)*x - 96.D0*Hr3(0,0,1)*x**2 - 784.D0/3.D0*Hr3(0,1,0 & + & ) - 592.D0/3.D0*Hr3(0,1,0)*x - 224.D0/3.D0*Hr3(0,1,0)*x**2 - & + & 32.D0/3.D0*Hr3(0,1,0)*dx + 104.D0*Hr3(0,1,1) - 132.D0*Hr3(0,1 & + & ,1)*x - 128.D0/3.D0*Hr3(0,1,1)*x**2 - 544.D0/3.D0*Hr3(0,1,1)* & + & dx ) + ggq2 = ggq2 + cf*ca**2 * ( - 140.D0/3.D0*Hr3(1,0,0) - 332.D0/3.D0& + & *Hr3(1,0,0)*x - 64.D0/3.D0*Hr3(1,0,0)*x**2 + 176.D0*Hr3(1,0,0 & + & )*dx + 440.D0/3.D0*Hr3(1,0,1) - 412.D0/3.D0*Hr3(1,0,1)*x - & + & 440.D0/3.D0*Hr3(1,0,1)*dx + 440.D0/3.D0*Hr3(1,1,0) - 412.D0/3.& + & D0*Hr3(1,1,0)*x - 440.D0/3.D0*Hr3(1,1,0)*dx + 632.D0/3.D0* & + & Hr3(1,1,1) - 340.D0/3.D0*Hr3(1,1,1)*x + 32.D0/3.D0*Hr3(1,1,1) & + & *x**2 - 688.D0/3.D0*Hr3(1,1,1)*dx + 192.D0*Hr4(-1,-1,-1,0) + & + & 96.D0*Hr4(-1,-1,-1,0)*x + 192.D0*Hr4(-1,-1,-1,0)*dx - 384.D0* & + & Hr4(-1,-1,0,0) - 192.D0*Hr4(-1,-1,0,0)*x - 384.D0*Hr4(-1,-1,0 & + & ,0)*dx - 320.D0*Hr4(-1,-1,0,1) - 160.D0*Hr4(-1,-1,0,1)*x - & + & 320.D0*Hr4(-1,-1,0,1)*dx - 160.D0*Hr4(-1,0,-1,0) - 80.D0*Hr4( & + & -1,0,-1,0)*x - 160.D0*Hr4(-1,0,-1,0)*dx + 176.D0*Hr4(-1,0,0,0 & + & ) + 88.D0*Hr4(-1,0,0,0)*x + 176.D0*Hr4(-1,0,0,0)*dx + 256.D0* & + & Hr4(-1,0,0,1) + 128.D0*Hr4(-1,0,0,1)*x + 256.D0*Hr4(-1,0,0,1) & + & *dx + 64.D0*Hr4(-1,0,1,0) + 32.D0*Hr4(-1,0,1,0)*x + 64.D0* & + & Hr4(-1,0,1,0)*dx ) + ggq2 = ggq2 + cf*ca**2 * ( 64.D0*Hr4(-1,0,1,1) + 32.D0*Hr4(-1,0,1 & + & ,1)*x + 64.D0*Hr4(-1,0,1,1)*dx - 352.D0*Hr4(0,-1,-1,0) + 16.D0& + & *Hr4(0,-1,-1,0)*x - 64.D0*Hr4(0,-1,-1,0)*dx + 176.D0*Hr4(0,-1 & + & ,0,0) + 152.D0*Hr4(0,-1,0,0)*x + 224.D0*Hr4(0,-1,0,0)*dx + & + & 256.D0*Hr4(0,-1,0,1) + 64.D0*Hr4(0,-1,0,1)*x + 128.D0*Hr4(0, & + & -1,0,1)*dx - 144.D0*Hr4(0,0,-1,0) + 8.D0*Hr4(0,0,-1,0)*x - & + & 128.D0*Hr4(0,0,0,0) + 120.D0*Hr4(0,0,0,0)*x + 104.D0*Hr4(0,0, & + & 0,1) + 100.D0*Hr4(0,0,0,1)*x + 64.D0*Hr4(0,0,1,0) + 128.D0* & + & Hr4(0,0,1,0)*x + 128.D0*Hr4(0,0,1,0)*dx - 64.D0*Hr4(0,0,1,1) & + & + 96.D0*Hr4(0,0,1,1)*x + 128.D0*Hr4(0,0,1,1)*dx + 104.D0* & + & Hr4(0,1,0,0) + 84.D0*Hr4(0,1,0,0)*x + 96.D0*Hr4(0,1,0,0)*dx & + & - 96.D0*Hr4(0,1,0,1) + 48.D0*Hr4(0,1,0,1)*x + 96.D0*Hr4(0,1, & + & 0,1)*dx - 96.D0*Hr4(0,1,1,0) + 48.D0*Hr4(0,1,1,0)*x + 96.D0* & + & Hr4(0,1,1,0)*dx - 128.D0*Hr4(0,1,1,1) + 16.D0*Hr4(0,1,1,1)*x & + & + 64.D0*Hr4(0,1,1,1)*dx + 32.D0*Hr4(1,0,-1,0) - 16.D0*Hr4(1, & + & 0,-1,0)*x ) + ggq2 = ggq2 + cf*ca**2 * ( - 32.D0*Hr4(1,0,-1,0)*dx - 48.D0*Hr4( & + & 1,0,0,0) + 24.D0*Hr4(1,0,0,0)*x + 48.D0*Hr4(1,0,0,0)*dx - 128.& + & D0*Hr4(1,0,0,1) + 64.D0*Hr4(1,0,0,1)*x + 128.D0*Hr4(1,0,0,1)* & + & dx - 192.D0*Hr4(1,0,1,0) + 96.D0*Hr4(1,0,1,0)*x + 192.D0*Hr4( & + & 1,0,1,0)*dx - 128.D0*Hr4(1,0,1,1) + 64.D0*Hr4(1,0,1,1)*x + & + & 128.D0*Hr4(1,0,1,1)*dx - 64.D0*Hr4(1,1,0,0) + 32.D0*Hr4(1,1,0 & + & ,0)*x + 64.D0*Hr4(1,1,0,0)*dx - 128.D0*Hr4(1,1,0,1) + 64.D0* & + & Hr4(1,1,0,1)*x + 128.D0*Hr4(1,1,0,1)*dx - 128.D0*Hr4(1,1,1,0) & + & + 64.D0*Hr4(1,1,1,0)*x + 128.D0*Hr4(1,1,1,0)*dx - 64.D0*Hr4( & + & 1,1,1,1) + 32.D0*Hr4(1,1,1,1)*x + 64.D0*Hr4(1,1,1,1)*dx ) + ggq2 = ggq2 + cf**2*ca * ( - 11629.D0/18.D0 + 3589.D0/36.D0*x + & + & 56.D0*x**2 + 163.D0*dx - 1472.D0/3.D0*z3 - 884.D0/3.D0*z3*x & + & - 32.D0*z3*x**2 + 216.D0*z3*dx + 2456.D0/9.D0*z2 - 5356.D0/9.& + & D0*z2*x + 96.D0*z2*x**2 - 160.D0*z2*dx - 784.D0/5.D0*z2**2 - & + & 184.D0/5.D0*z2**2*x - 432.D0/5.D0*z2**2*dx + 176.D0*Hr1(-1)* & + & z3 + 88.D0*Hr1(-1)*z3*x + 176.D0*Hr1(-1)*z3*dx + 144.D0*Hr1( & + & -1)*z2 + 88.D0*Hr1(-1)*z2*x - 48.D0*Hr1(-1)*z2*dx - 9925.D0/ & + & 27.D0*Hr1(0) + 7061.D0/27.D0*Hr1(0)*x + 2680.D0/27.D0*Hr1(0)* & + & x**2 - 64.D0*Hr1(0)*z3 + 64.D0*Hr1(0)*z3*x - 752.D0/3.D0*Hr1( & + & 0)*z2 - 440.D0/3.D0*Hr1(0)*z2*x - 16148.D0/27.D0*Hr1(1) + & + & 10936.D0/27.D0*Hr1(1)*x + 1384.D0/27.D0*Hr1(1)*x**2 + 13006.D0& + & /27.D0*Hr1(1)*dx - 48.D0*Hr1(1)*z3 + 24.D0*Hr1(1)*z3*x + 48.D0& + & *Hr1(1)*z3*dx + 1144.D0/3.D0*Hr1(1)*z2 - 788.D0/3.D0*Hr1(1)* & + & z2*x - 472.D0/3.D0*Hr1(1)*z2*dx - 160.D0*Hr2(-1,-1)*z2 - 80.D0& + & *Hr2(-1,-1)*z2*x - 160.D0*Hr2(-1,-1)*z2*dx - 608.D0*Hr2(-1,0) & + & - 700.D0*Hr2(-1,0)*x ) + ggq2 = ggq2 + cf**2*ca * ( - 32.D0*Hr2(-1,0)*dx - 32.D0*Hr2(-1,0 & + & )*z2 - 16.D0*Hr2(-1,0)*z2*x - 32.D0*Hr2(-1,0)*z2*dx + 96.D0* & + & Hr2(0,-1)*z2 - 2590.D0/9.D0*Hr2(0,0) + 4631.D0/9.D0*Hr2(0,0)* & + & x - 448.D0/9.D0*Hr2(0,0)*x**2 - 16.D0*Hr2(0,0)*z2*x - 2456.D0/& + & 9.D0*Hr2(0,1) - 944.D0/9.D0*Hr2(0,1)*x - 96.D0*Hr2(0,1)*x**2 & + & + 128.D0*Hr2(0,1)*dx + 160.D0*Hr2(0,1)*z2 - 32.D0*Hr2(0,1)* & + & z2*x - 32.D0*Hr2(0,1)*z2*dx - 224.D0*Hr2(1,0) + 80.D0/3.D0* & + & Hr2(1,0)*x + 764.D0/3.D0*Hr2(1,0)*dx - 32.D0*Hr2(1,0)*z2 + 16.& + & D0*Hr2(1,0)*z2*x + 32.D0*Hr2(1,0)*z2*dx - 884.D0/9.D0*Hr2(1,1 & + & ) - 1448.D0/9.D0*Hr2(1,1)*x - 416.D0/9.D0*Hr2(1,1)*x**2 + 64.D& + & 0/9.D0*Hr2(1,1)*dx + 64.D0*Hr2(1,1)*z2 - 32.D0*Hr2(1,1)*z2*x & + & - 64.D0*Hr2(1,1)*z2*dx + 480.D0*Hr3(-1,-1,0) + 304.D0*Hr3(-1 & + & ,-1,0)*x + 96.D0*Hr3(-1,-1,0)*dx - 240.D0*Hr3(-1,0,0) - 144.D0& + & *Hr3(-1,0,0)*x - 48.D0*Hr3(-1,0,0)*dx + 96.D0*Hr3(-1,0,1) + & + & 64.D0*Hr3(-1,0,1)*x + 96.D0*Hr3(-1,0,1)*dx - 576.D0*Hr3(0,-1, & + & 0) ) + ggq2 = ggq2 + cf**2*ca * ( - 16.D0*Hr3(0,-1,0)*x - 760.D0/3.D0* & + & Hr3(0,0,0) + 608.D0/3.D0*Hr3(0,0,0)*x - 128.D0/3.D0*Hr3(0,0,0 & + & )*x**2 + 752.D0/3.D0*Hr3(0,0,1) + 392.D0/3.D0*Hr3(0,0,1)*x - & + & 16.D0/3.D0*Hr3(0,1,0) + 224.D0/3.D0*Hr3(0,1,0)*x + 96.D0*Hr3( & + & 0,1,0)*dx - 176.D0/3.D0*Hr3(0,1,1) + 448.D0/3.D0*Hr3(0,1,1)*x & + & + 32.D0*Hr3(0,1,1)*x**2 + 144.D0*Hr3(0,1,1)*dx - 384.D0*Hr3( & + & 1,0,0) + 232.D0*Hr3(1,0,0)*x + 128.D0*Hr3(1,0,0)*dx - 424.D0/ & + & 3.D0*Hr3(1,0,1) + 332.D0/3.D0*Hr3(1,0,1)*x + 328.D0/3.D0*Hr3( & + & 1,0,1)*dx - 8.D0/3.D0*Hr3(1,1,0) + 148.D0/3.D0*Hr3(1,1,0)*x & + & + 8.D0/3.D0*Hr3(1,1,0)*dx - 1112.D0/3.D0*Hr3(1,1,1) + 712.D0/& + & 3.D0*Hr3(1,1,1)*x - 32.D0/3.D0*Hr3(1,1,1)*x**2 + 1120.D0/3.D0 & + & *Hr3(1,1,1)*dx - 192.D0*Hr4(-1,-1,-1,0) - 96.D0*Hr4(-1,-1,-1, & + & 0)*x - 192.D0*Hr4(-1,-1,-1,0)*dx + 128.D0*Hr4(-1,-1,0,0) + 64.& + & D0*Hr4(-1,-1,0,0)*x + 128.D0*Hr4(-1,-1,0,0)*dx + 64.D0*Hr4(-1 & + & ,-1,0,1) + 32.D0*Hr4(-1,-1,0,1)*x + 64.D0*Hr4(-1,-1,0,1)*dx & + & + 96.D0*Hr4(-1,0,-1,0) ) + ggq2 = ggq2 + cf**2*ca * ( 48.D0*Hr4(-1,0,-1,0)*x + 96.D0*Hr4(-1, & + & 0,-1,0)*dx + 48.D0*Hr4(-1,0,0,0) + 24.D0*Hr4(-1,0,0,0)*x + 48.& + & D0*Hr4(-1,0,0,0)*dx - 64.D0*Hr4(-1,0,1,1) - 32.D0*Hr4(-1,0,1, & + & 1)*x - 64.D0*Hr4(-1,0,1,1)*dx + 192.D0*Hr4(0,-1,-1,0) - 96.D0 & + & *Hr4(0,-1,0,0) - 224.D0*Hr4(0,0,-1,0) + 16.D0*Hr4(0,0,-1,0)*x & + & + 64.D0*Hr4(0,0,0,0) + 64.D0*Hr4(0,0,0,0)*x + 32.D0*Hr4(0,0, & + & 0,1)*x - 64.D0*Hr4(0,0,1,0) + 32.D0*Hr4(0,0,1,0)*x - 112.D0* & + & Hr4(0,0,1,1) - 8.D0*Hr4(0,0,1,1)*x - 224.D0*Hr4(0,1,0,0) + 64.& + & D0*Hr4(0,1,0,0)*x + 64.D0*Hr4(0,1,0,0)*dx - 64.D0*Hr4(0,1,0,1 & + & ) + 32.D0*Hr4(0,1,0,1)*x + 32.D0*Hr4(0,1,0,1)*dx - 32.D0*Hr4( & + & 0,1,1,0) + 16.D0*Hr4(0,1,1,0)*x + 32.D0*Hr4(0,1,1,0)*dx + 112.& + & D0*Hr4(0,1,1,1) - 8.D0*Hr4(0,1,1,1)*x - 64.D0*Hr4(0,1,1,1)*dx & + & - 160.D0*Hr4(1,0,-1,0) + 80.D0*Hr4(1,0,-1,0)*x + 160.D0*Hr4( & + & 1,0,-1,0)*dx - 80.D0*Hr4(1,0,0,0) + 40.D0*Hr4(1,0,0,0)*x + 80.& + & D0*Hr4(1,0,0,0)*dx + 64.D0*Hr4(1,0,1,1) - 32.D0*Hr4(1,0,1,1)* & + & x ) + ggq2 = ggq2 + cf**2*ca * ( - 64.D0*Hr4(1,0,1,1)*dx - 160.D0*Hr4( & + & 1,1,0,0) + 80.D0*Hr4(1,1,0,0)*x + 160.D0*Hr4(1,1,0,0)*dx + 32.& + & D0*Hr4(1,1,0,1) - 16.D0*Hr4(1,1,0,1)*x - 32.D0*Hr4(1,1,0,1)* & + & dx + 96.D0*Hr4(1,1,1,0) - 48.D0*Hr4(1,1,1,0)*x - 96.D0*Hr4(1, & + & 1,1,0)*dx + 128.D0*Hr4(1,1,1,1) - 64.D0*Hr4(1,1,1,1)*x - 128.D& + & 0*Hr4(1,1,1,1)*dx ) + ggq2 = ggq2 + cf**3 * ( 475.D0/2.D0 - 363.D0/4.D0*x - 94.D0*dx + & + & 416.D0*z3 + 208.D0*z3*x - 240.D0*z3*dx - 164.D0*z2 + 520.D0* & + & z2*x + 112.D0*z2*dx + 744.D0/5.D0*z2**2 + 12.D0*z2**2*x + 512.& + & D0/5.D0*z2**2*dx - 224.D0*Hr1(-1)*z2 - 160.D0*Hr1(-1)*z2*x - & + & 96.D0*Hr1(-1)*z2*dx + 91.D0*Hr1(0) - 245.D0*Hr1(0)*x + 192.D0 & + & *Hr1(0)*z3 - 48.D0*Hr1(0)*z3*x + 64.D0*Hr1(0)*z2 + 36.D0*Hr1( & + & 0)*z2*x + 316.D0*Hr1(1) - 258.D0*Hr1(1)*x - 94.D0*Hr1(1)*dx & + & + 256.D0*Hr1(1)*z3 - 128.D0*Hr1(1)*z3*x - 256.D0*Hr1(1)*z3* & + & dx - 256.D0*Hr1(1)*z2 + 152.D0*Hr1(1)*z2*x + 96.D0*Hr1(1)*z2* & + & dx + 688.D0*Hr2(-1,0) + 608.D0*Hr2(-1,0)*x + 112.D0*Hr2(-1,0) & + & *dx + 64.D0*Hr2(-1,0)*z2 + 32.D0*Hr2(-1,0)*z2*x + 64.D0*Hr2( & + & -1,0)*z2*dx - 64.D0*Hr2(0,-1)*z2 - 70.D0*Hr2(0,0) - 555.D0* & + & Hr2(0,0)*x + 48.D0*Hr2(0,0)*z2 - 24.D0*Hr2(0,0)*z2*x + 164.D0 & + & *Hr2(0,1) + 88.D0*Hr2(0,1)*x - 96.D0*Hr2(0,1)*z2 + 16.D0*Hr2( & + & 0,1)*z2*x - 16.D0*Hr2(1,0) - 24.D0*Hr2(1,0)*x - 56.D0*Hr2(1,0 & + & )*dx ) + ggq2 = ggq2 + cf**3 * ( 64.D0*Hr2(1,0)*z2 - 32.D0*Hr2(1,0)*z2*x & + & - 64.D0*Hr2(1,0)*z2*dx + 96.D0*Hr2(1,1) + 54.D0*Hr2(1,1)*x & + & - 92.D0*Hr2(1,1)*dx - 96.D0*Hr2(1,1)*z2 + 48.D0*Hr2(1,1)*z2* & + & x + 96.D0*Hr2(1,1)*z2*dx - 448.D0*Hr3(-1,-1,0) - 320.D0*Hr3( & + & -1,-1,0)*x - 192.D0*Hr3(-1,-1,0)*dx + 384.D0*Hr3(-1,0,0) + & + & 224.D0*Hr3(-1,0,0)*x + 192.D0*Hr3(-1,0,0)*dx + 480.D0*Hr3(0, & + & -1,0) + 80.D0*Hr3(0,-1,0)*x + 16.D0*Hr3(0,0,0) - 132.D0*Hr3(0 & + & ,0,0)*x - 64.D0*Hr3(0,0,1) + 44.D0*Hr3(0,0,1)*x + 48.D0*Hr3(0 & + & ,1,0)*x - 16.D0*Hr3(0,1,1) - 52.D0*Hr3(0,1,1)*x + 192.D0*Hr3( & + & 1,0,0) - 108.D0*Hr3(1,0,0)*x - 48.D0*Hr3(1,0,0)*dx + 32.D0* & + & Hr3(1,0,1) + 8.D0*Hr3(1,0,1)*x - 96.D0*Hr3(1,1,0) + 64.D0* & + & Hr3(1,1,0)*x + 96.D0*Hr3(1,1,0)*dx + 160.D0*Hr3(1,1,1) - 124.D& + & 0*Hr3(1,1,1)*x - 144.D0*Hr3(1,1,1)*dx - 128.D0*Hr4(-1,-1,0,0) & + & - 64.D0*Hr4(-1,-1,0,0)*x - 128.D0*Hr4(-1,-1,0,0)*dx - 64.D0* & + & Hr4(-1,0,-1,0) - 32.D0*Hr4(-1,0,-1,0)*x - 64.D0*Hr4(-1,0,-1,0 & + & )*dx ) + ggq2 = ggq2 + cf**3 * ( 32.D0*Hr4(-1,0,0,0) + 16.D0*Hr4(-1,0,0,0) & + & *x + 32.D0*Hr4(-1,0,0,0)*dx - 128.D0*Hr4(0,-1,-1,0) + 128.D0* & + & Hr4(0,-1,0,0) + 32.D0*Hr4(0,-1,0,0)*x + 256.D0*Hr4(0,0,-1,0) & + & - 32.D0*Hr4(0,0,0,0) - 32.D0*Hr4(0,0,0,0)*x - 48.D0*Hr4(0,0, & + & 0,1) + 24.D0*Hr4(0,0,0,1)*x + 48.D0*Hr4(0,0,1,1) - 24.D0*Hr4( & + & 0,0,1,1)*x + 80.D0*Hr4(0,1,0,0) - 8.D0*Hr4(0,1,0,0)*x + 32.D0 & + & *Hr4(0,1,0,1) - 16.D0*Hr4(0,1,0,1)*x + 16.D0*Hr4(0,1,1,1) - 8.& + & D0*Hr4(0,1,1,1)*x + 192.D0*Hr4(1,0,-1,0) - 96.D0*Hr4(1,0,-1,0 & + & )*x - 192.D0*Hr4(1,0,-1,0)*dx + 64.D0*Hr4(1,0,1,0) - 32.D0* & + & Hr4(1,0,1,0)*x - 64.D0*Hr4(1,0,1,0)*dx + 64.D0*Hr4(1,0,1,1) & + & - 32.D0*Hr4(1,0,1,1)*x - 64.D0*Hr4(1,0,1,1)*dx + 96.D0*Hr4(1 & + & ,1,0,0) - 48.D0*Hr4(1,1,0,0)*x - 96.D0*Hr4(1,1,0,0)*dx + 96.D0& + & *Hr4(1,1,0,1) - 48.D0*Hr4(1,1,0,1)*x - 96.D0*Hr4(1,1,0,1)*dx & + & + 32.D0*Hr4(1,1,1,0) - 16.D0*Hr4(1,1,1,0)*x - 32.D0*Hr4(1,1, & + & 1,0)*dx - 64.D0*Hr4(1,1,1,1) + 32.D0*Hr4(1,1,1,1)*x + 64.D0* & + & Hr4(1,1,1,1)*dx ) + ggq2 = ggq2 + nf*cf*ca * ( - 2320.D0/9.D0 + 148.D0/3.D0*x - 1048.& + & D0/9.D0*x**2 + 1934.D0/9.D0*dx + 448.D0/3.D0*z3 - 184.D0/3.D0 & + & *z3*x - 80.D0*z3*dx - 256.D0/9.D0*z2 + 308.D0/9.D0*z2*x + 32.D& + & 0/3.D0*z2*x**2 - 112.D0/3.D0*z2*dx - 128.D0/3.D0*Hr1(-1)*z2 & + & - 64.D0/3.D0*Hr1(-1)*z2*x - 128.D0/3.D0*Hr1(-1)*z2*dx + 6656.& + & D0/27.D0*Hr1(0) + 1688.D0/27.D0*Hr1(0)*x + 2000.D0/27.D0*Hr1( & + & 0)*x**2 + 1208.D0/27.D0*Hr1(0)*dx - 64.D0/3.D0*Hr1(0)*z2 - 80.& + & D0/3.D0*Hr1(0)*z2*x - 32.D0/3.D0*Hr1(0)*z2*dx - 1184.D0/27.D0 & + & *Hr1(1) + 1720.D0/27.D0*Hr1(1)*x + 400.D0/27.D0*Hr1(1)*x**2 & + & + 2008.D0/27.D0*Hr1(1)*dx + 16.D0/3.D0*Hr1(1)*z2 - 8.D0/3.D0 & + & *Hr1(1)*z2*x - 16.D0/3.D0*Hr1(1)*z2*dx - 80.D0/3.D0*Hr2(-1,0) & + & + 8.D0*Hr2(-1,0)*x - 32.D0/9.D0*Hr2(-1,0)*x**2 - 656.D0/9.D0 & + & *Hr2(-1,0)*dx - 1088.D0/9.D0*Hr2(0,0) - 668.D0/9.D0*Hr2(0,0)* & + & x - 32.D0/9.D0*Hr2(0,0)*x**2 + 256.D0/9.D0*Hr2(0,1) - 236.D0/ & + & 9.D0*Hr2(0,1)*x - 32.D0/3.D0*Hr2(0,1)*x**2 - 320.D0/9.D0*Hr2( & + & 0,1)*dx ) + ggq2 = ggq2 + nf*cf*ca * ( 320.D0/9.D0*Hr2(1,0) - 280.D0/9.D0* & + & Hr2(1,0)*x - 320.D0/9.D0*Hr2(1,0)*dx + 880.D0/9.D0*Hr2(1,1) & + & - 488.D0/9.D0*Hr2(1,1)*x + 32.D0/9.D0*Hr2(1,1)*x**2 - 104.D0 & + & *Hr2(1,1)*dx - 128.D0/3.D0*Hr3(-1,-1,0) - 64.D0/3.D0*Hr3(-1, & + & -1,0)*x - 128.D0/3.D0*Hr3(-1,-1,0)*dx + 64.D0/3.D0*Hr3(-1,0,0 & + & ) + 32.D0/3.D0*Hr3(-1,0,0)*x + 64.D0/3.D0*Hr3(-1,0,0)*dx + 64.& + & D0/3.D0*Hr3(-1,0,1) + 32.D0/3.D0*Hr3(-1,0,1)*x + 64.D0/3.D0* & + & Hr3(-1,0,1)*dx + 160.D0/3.D0*Hr3(0,-1,0) - 16.D0*Hr3(0,-1,0)* & + & x - 32.D0/3.D0*Hr3(0,-1,0)*dx + 32.D0/3.D0*Hr3(0,0,0) + 64.D0/& + & 3.D0*Hr3(0,0,1) + 32.D0/3.D0*Hr3(0,0,1)*x - 32.D0/3.D0*Hr3(0, & + & 1,0) + 16.D0/3.D0*Hr3(0,1,0)*x + 32.D0/3.D0*Hr3(0,1,0)*dx - & + & 48.D0*Hr3(0,1,1) + 8.D0*Hr3(0,1,1)*x + 80.D0/3.D0*Hr3(0,1,1)* & + & dx + 32.D0/3.D0*Hr3(1,0,0) - 16.D0/3.D0*Hr3(1,0,0)*x - 32.D0/ & + & 3.D0*Hr3(1,0,0)*dx - 80.D0/3.D0*Hr3(1,0,1) + 40.D0/3.D0*Hr3(1 & + & ,0,1)*x + 80.D0/3.D0*Hr3(1,0,1)*dx - 80.D0/3.D0*Hr3(1,1,0) + & + & 40.D0/3.D0*Hr3(1,1,0)*x ) + ggq2 = ggq2 + nf*cf*ca * ( 80.D0/3.D0*Hr3(1,1,0)*dx - 80.D0/3.D0* & + & Hr3(1,1,1) + 40.D0/3.D0*Hr3(1,1,1)*x + 80.D0/3.D0*Hr3(1,1,1)* & + & dx ) + ggq2 = ggq2 + nf*cf**2 * ( 8707.D0/27.D0 + 3301.D0/54.D0*x - 224.D& + & 0/9.D0*x**2 - 3250.D0/9.D0*dx - 496.D0/3.D0*z3 + 248.D0/3.D0* & + & z3*x + 96.D0*z3*dx - 128.D0/9.D0*z2 - 560.D0/9.D0*z2*x + 496.D& + & 0/9.D0*z2*dx - 5174.D0/27.D0*Hr1(0) - 3134.D0/27.D0*Hr1(0)*x & + & - 352.D0/27.D0*Hr1(0)*x**2 - 1520.D0/27.D0*Hr1(0)*dx + 32.D0/& + & 3.D0*Hr1(0)*z2 + 80.D0/3.D0*Hr1(0)*z2*x + 64.D0/3.D0*Hr1(0)* & + & z2*dx + 8.D0/27.D0*Hr1(1) - 1360.D0/27.D0*Hr1(1)*x - 56.D0/27.& + & D0*Hr1(1)*dx + 32.D0/3.D0*Hr1(1)*z2 - 16.D0/3.D0*Hr1(1)*z2*x & + & - 32.D0/3.D0*Hr1(1)*z2*dx - 48.D0*Hr2(-1,0)*x + 64.D0/9.D0* & + & Hr2(-1,0)*x**2 + 496.D0/9.D0*Hr2(-1,0)*dx + 2236.D0/9.D0*Hr2( & + & 0,0) + 1306.D0/9.D0*Hr2(0,0)*x + 64.D0/9.D0*Hr2(0,0)*x**2 + & + & 128.D0/9.D0*Hr2(0,1) + 128.D0/9.D0*Hr2(0,1)*x - 8.D0/3.D0* & + & Hr2(1,0)*x - 32.D0/3.D0*Hr2(1,0)*dx - 712.D0/9.D0*Hr2(1,1) + & + & 512.D0/9.D0*Hr2(1,1)*x + 664.D0/9.D0*Hr2(1,1)*dx - 64.D0*Hr3( & + & 0,-1,0) + 32.D0*Hr3(0,-1,0)*x + 64.D0/3.D0*Hr3(0,-1,0)*dx + & + & 16.D0/3.D0*Hr3(0,0,0) ) + ggq2 = ggq2 + nf*cf**2 * ( - 32.D0/3.D0*Hr3(0,0,0)*x - 32.D0/3.D0& + & *Hr3(0,0,1) + 16.D0/3.D0*Hr3(0,0,1)*x - 32.D0/3.D0*Hr3(0,1,0) & + & + 16.D0/3.D0*Hr3(0,1,0)*x - 16.D0/3.D0*Hr3(0,1,1) + 8.D0/3.D0& + & *Hr3(0,1,1)*x - 16.D0*Hr3(1,0,0) + 8.D0*Hr3(1,0,0)*x + 16.D0* & + & Hr3(1,0,0)*dx - 32.D0/3.D0*Hr3(1,0,1) + 16.D0/3.D0*Hr3(1,0,1) & + & *x + 32.D0/3.D0*Hr3(1,0,1)*dx - 64.D0/3.D0*Hr3(1,1,0) + 32.D0/& + & 3.D0*Hr3(1,1,0)*x + 64.D0/3.D0*Hr3(1,1,0)*dx + 80.D0/3.D0* & + & Hr3(1,1,1) - 40.D0/3.D0*Hr3(1,1,1)*x - 80.D0/3.D0*Hr3(1,1,1)* & + & dx + 64.D0*Hr4(0,0,0,0) - 32.D0*Hr4(0,0,0,0)*x ) + ggq2 = ggq2 + nf2*cf * ( 16.D0/9.D0 + 32.D0/9.D0*x - 16.D0/9.D0 & + & *dx + 80.D0/9.D0*Hr1(1) - 64.D0/9.D0*Hr1(1)*x - 80.D0/9.D0* & + & Hr1(1)*dx - 16.D0/3.D0*Hr2(1,1) + 8.D0/3.D0*Hr2(1,1)*x + 16.D0& + & /3.D0*Hr2(1,1)*dx ) +! + X2GQA = GGQ2 +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The regular piece of the gg splitting functions P_gg^(2). +! + FUNCTION X2GGA (X, NF) +! + IMPLICIT REAL*8 (A - Z) + COMPLEX*16 HC1, HC2, HC3, HC4 + INTEGER NF, NF2, N1, N2, NW, I1, I2, I3, N + PARAMETER ( N1 = -1, N2 = 1, NW = 4 ) + DIMENSION HC1(N1:N2),HC2(N1:N2,N1:N2),HC3(N1:N2,N1:N2,N1:N2), & + & HC4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HR1(N1:N2),HR2(N1:N2,N1:N2),HR3(N1:N2,N1:N2,N1:N2), & + & HR4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HI1(N1:N2),HI2(N1:N2,N1:N2),HI3(N1:N2,N1:N2,N1:N2), & + & HI4(N1:N2,N1:N2,N1:N2,N1:N2) + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0, & + & Z5 = 1.0369 27755 14336 99263 D0 ) +! +! ..The soft coefficient for use in X2GGB and X2GGC +! +! COMMON / P2GSOFT / A3G +! +! ...Colour factors +! + !CF = 4./3.D0 + !CA = 3.D0 + NF2 = NF*NF +! +! ...Some abbreviations +! + DX = 1.D0/X + DM = 1.D0/(1.D0-X) + DP = 1.D0/(1.D0+X) +! +! ...The harmonic polylogs up to weight 4 by Gehrmann and Remiddi +! + CALL HPLOG (X, NW, HC1,HC2,HC3,HC4, HR1,HR2,HR3,HR4, & + & HI1,HI2,HI3,HI4, N1, N2) +! +! ...The splitting function in terms of the harmonic polylogs +! (without the delta(1-x) part, but with the soft contribution) +! + ggg2 = & + & + ca**3 * ( - 54088.D0/27.D0 + 49678.D0/27.D0*x - 146182.D0/81.& + & D0*x**2 + 146182.D0/81.D0*dx + 490.D0/3.D0*dm + 1064.D0/3.D0* & + & z3 + 704.D0/3.D0*z3*x + 1408.D0/3.D0*z3*x**2 - 1144.D0/3.D0* & + & z3*dx + 176.D0/3.D0*z3*dm + 976.D0/3.D0*z2 - 2632.D0/9.D0*z2* & + & x + 1072.D0/9.D0*z2*x**2 - 3112.D0/9.D0*z2*dx - 1072.D0/9.D0* & + & z2*dp - 1072.D0/9.D0*z2*dm - 272.D0*z2**2 - 1152.D0/5.D0* & + & z2**2*x - 416.D0/5.D0*z2**2*x**2 - 464.D0/5.D0*z2**2*dx + 88.D& + & 0*z2**2*dp - 24.D0/5.D0*z2**2*dm - 384.D0*Hr1(-1)*z3 - 192.D0 & + & *Hr1(-1)*z3*x - 192.D0*Hr1(-1)*z3*x**2 - 192.D0*Hr1(-1)*z3*dx & + & + 192.D0*Hr1(-1)*z3*dp - 424.D0*Hr1(-1)*z2 - 424.D0*Hr1(-1)* & + & z2*x - 88.D0*Hr1(-1)*z2*x**2 - 88.D0*Hr1(-1)*z2*dx + 30794.D0/& + & 27.D0*Hr1(0) + 9374.D0/27.D0*Hr1(0)*x + 10604.D0/9.D0*Hr1(0)* & + & x**2 + 6320.D0/27.D0*Hr1(0)*dx + 8.D0/3.D0*Hr1(0)*dm - 160.D0 & + & *Hr1(0)*z3*x + 192.D0*Hr1(0)*z3*x**2 - 32.D0*Hr1(0)*z3*dx - & + & 80.D0*Hr1(0)*z3*dp - 112.D0*Hr1(0)*z3*dm + 1480.D0/3.D0*Hr1(0 & + & )*z2 ) + ggg2 = ggg2 + ca**3 * ( 736.D0/3.D0*Hr1(0)*z2*x + 1936.D0/3.D0* & + & Hr1(0)*z2*x**2 - 176.D0/3.D0*Hr1(0)*z2*dx - 88.D0/3.D0*Hr1(0) & + & *z2*dp + 124.D0/9.D0*Hr1(1) - 124.D0/9.D0*Hr1(1)*x + 1652.D0/ & + & 27.D0*Hr1(1)*x**2 - 1652.D0/27.D0*Hr1(1)*dx + 192.D0*Hr1(1)* & + & z3 - 96.D0*Hr1(1)*z3*x + 96.D0*Hr1(1)*z3*x**2 - 96.D0*Hr1(1)* & + & z3*dx - 96.D0*Hr1(1)*z3*dm - 24.D0*Hr1(1)*z2 + 24.D0*Hr1(1)* & + & z2*x + 88.D0*Hr1(1)*z2*x**2 - 88.D0*Hr1(1)*z2*dx + 512.D0* & + & Hr2(-1,-1)*z2 + 256.D0*Hr2(-1,-1)*z2*x + 256.D0*Hr2(-1,-1)*z2 & + & *x**2 + 256.D0*Hr2(-1,-1)*z2*dx - 256.D0*Hr2(-1,-1)*z2*dp - & + & 872.D0/9.D0*Hr2(-1,0) - 3016.D0/9.D0*Hr2(-1,0)*x - 680.D0/3.D0& + & *Hr2(-1,0)*x**2 - 680.D0/3.D0*Hr2(-1,0)*dx - 2144.D0/9.D0* & + & Hr2(-1,0)*dp - 576.D0*Hr2(-1,0)*z2 - 288.D0*Hr2(-1,0)*z2*x - & + & 288.D0*Hr2(-1,0)*z2*x**2 - 288.D0*Hr2(-1,0)*z2*dx + 288.D0* & + & Hr2(-1,0)*z2*dp - 768.D0*Hr2(0,-1)*z2 - 96.D0*Hr2(0,-1)*z2*x & + & - 352.D0*Hr2(0,-1)*z2*x**2 - 160.D0*Hr2(0,-1)*z2*dx + 256.D0 & + & *Hr2(0,-1)*z2*dp ) + ggg2 = ggg2 + ca**3 * ( 96.D0*Hr2(0,-1)*z2*dm - 11620.D0/9.D0* & + & Hr2(0,0) + 1052.D0/3.D0*Hr2(0,0)*x - 12136.D0/9.D0*Hr2(0,0)* & + & x**2 + 1072.D0/9.D0*Hr2(0,0)*dp + 1072.D0/9.D0*Hr2(0,0)*dm + & + & 96.D0*Hr2(0,0)*z2 - 352.D0*Hr2(0,0)*z2*x + 256.D0*Hr2(0,0)*z2 & + & *x**2 - 128.D0*Hr2(0,0)*z2*dp - 128.D0*Hr2(0,0)*z2*dm - 976.D0& + & /3.D0*Hr2(0,1) - 128.D0/3.D0*Hr2(0,1)*x - 1072.D0/9.D0*Hr2(0, & + & 1)*x**2 + 1072.D0/9.D0*Hr2(0,1)*dx + 2144.D0/9.D0*Hr2(0,1)*dm & + & - 160.D0*Hr2(0,1)*z2*x + 32.D0*Hr2(0,1)*z2*x**2 - 96.D0*Hr2( & + & 0,1)*z2*dx + 32.D0*Hr2(0,1)*z2*dp - 64.D0*Hr2(0,1)*z2*dm - & + & 2344.D0/9.D0*Hr2(1,0) + 200.D0/9.D0*Hr2(1,0)*x - 1072.D0/9.D0 & + & *Hr2(1,0)*x**2 + 1072.D0/9.D0*Hr2(1,0)*dx + 2144.D0/9.D0*Hr2( & + & 1,0)*dm + 192.D0*Hr2(1,0)*z2 - 96.D0*Hr2(1,0)*z2*x + 96.D0* & + & Hr2(1,0)*z2*x**2 - 96.D0*Hr2(1,0)*z2*dx - 96.D0*Hr2(1,0)*z2* & + & dm - 48.D0*Hr3(-1,-1,0) - 48.D0*Hr3(-1,-1,0)*x + 176.D0*Hr3( & + & -1,-1,0)*x**2 + 176.D0*Hr3(-1,-1,0)*dx + 608.D0*Hr3(-1,0,0) & + & + 608.D0*Hr3(-1,0,0)*x ) + ggg2 = ggg2 + ca**3 * ( 1408.D0/3.D0*Hr3(-1,0,0)*x**2 + 1408.D0/3.& + & D0*Hr3(-1,0,0)*dx + 400.D0*Hr3(-1,0,1) + 400.D0*Hr3(-1,0,1)*x & + & + 176.D0*Hr3(-1,0,1)*x**2 + 176.D0*Hr3(-1,0,1)*dx + 640.D0/3.& + & D0*Hr3(0,-1,0) + 160.D0*Hr3(0,-1,0)*x + 352.D0*Hr3(0,-1,0)* & + & x**2 - 176.D0/3.D0*Hr3(0,-1,0)*dx + 176.D0/3.D0*Hr3(0,-1,0)* & + & dm - 368.D0*Hr3(0,0,0) + 464.D0/3.D0*Hr3(0,0,0)*x - 704.D0* & + & Hr3(0,0,0)*x**2 - 1480.D0/3.D0*Hr3(0,0,1) - 256.D0/3.D0*Hr3(0 & + & ,0,1)*x - 1936.D0/3.D0*Hr3(0,0,1)*x**2 + 88.D0/3.D0*Hr3(0,0,1 & + & )*dm - 688.D0/3.D0*Hr3(0,1,0) + 464.D0/3.D0*Hr3(0,1,0)*x - & + & 352.D0*Hr3(0,1,0)*x**2 + 352.D0/3.D0*Hr3(0,1,0)*dx - 776.D0/3.& + & D0*Hr3(1,0,0) + 688.D0/3.D0*Hr3(1,0,0)*x - 880.D0/3.D0*Hr3(1, & + & 0,0)*x**2 + 880.D0/3.D0*Hr3(1,0,0)*dx + 88.D0/3.D0*Hr3(1,0,0) & + & *dm - 768.D0*Hr4(-1,-1,0,0) - 384.D0*Hr4(-1,-1,0,0)*x - 384.D0& + & *Hr4(-1,-1,0,0)*x**2 - 384.D0*Hr4(-1,-1,0,0)*dx + 384.D0*Hr4( & + & -1,-1,0,0)*dp - 512.D0*Hr4(-1,-1,0,1) - 256.D0*Hr4(-1,-1,0,1) & + & *x ) + ggg2 = ggg2 + ca**3 * ( - 256.D0*Hr4(-1,-1,0,1)*x**2 - 256.D0* & + & Hr4(-1,-1,0,1)*dx + 256.D0*Hr4(-1,-1,0,1)*dp - 256.D0*Hr4(-1, & + & 0,-1,0) - 128.D0*Hr4(-1,0,-1,0)*x - 128.D0*Hr4(-1,0,-1,0)* & + & x**2 - 128.D0*Hr4(-1,0,-1,0)*dx + 128.D0*Hr4(-1,0,-1,0)*dp + & + & 512.D0*Hr4(-1,0,0,0) + 256.D0*Hr4(-1,0,0,0)*x + 256.D0*Hr4(-1 & + & ,0,0,0)*x**2 + 256.D0*Hr4(-1,0,0,0)*dx - 256.D0*Hr4(-1,0,0,0) & + & *dp + 512.D0*Hr4(-1,0,0,1) + 256.D0*Hr4(-1,0,0,1)*x + 256.D0* & + & Hr4(-1,0,0,1)*x**2 + 256.D0*Hr4(-1,0,0,1)*dx - 256.D0*Hr4(-1, & + & 0,0,1)*dp + 128.D0*Hr4(-1,0,1,0) + 64.D0*Hr4(-1,0,1,0)*x + 64.& + & D0*Hr4(-1,0,1,0)*x**2 + 64.D0*Hr4(-1,0,1,0)*dx - 64.D0*Hr4(-1 & + & ,0,1,0)*dp - 512.D0*Hr4(0,-1,-1,0) + 64.D0*Hr4(0,-1,-1,0)*x & + & - 192.D0*Hr4(0,-1,-1,0)*x**2 - 64.D0*Hr4(0,-1,-1,0)*dx + 128.& + & D0*Hr4(0,-1,-1,0)*dp + 64.D0*Hr4(0,-1,-1,0)*dm + 512.D0*Hr4(0 & + & ,-1,0,0) + 416.D0*Hr4(0,-1,0,0)*x + 352.D0*Hr4(0,-1,0,0)*x**2 & + & + 224.D0*Hr4(0,-1,0,0)*dx - 288.D0*Hr4(0,-1,0,0)*dp - 64.D0* & + & Hr4(0,-1,0,0)*dm ) + ggg2 = ggg2 + ca**3 * ( 512.D0*Hr4(0,-1,0,1) + 128.D0*Hr4(0,-1,0, & + & 1)*x + 256.D0*Hr4(0,-1,0,1)*x**2 + 128.D0*Hr4(0,-1,0,1)*dx - & + & 192.D0*Hr4(0,-1,0,1)*dp - 64.D0*Hr4(0,-1,0,1)*dm - 64.D0*Hr4( & + & 0,0,-1,0) + 64.D0*Hr4(0,0,-1,0)*x + 128.D0*Hr4(0,0,-1,0)*x**2 & + & - 64.D0*Hr4(0,0,-1,0)*dp - 64.D0*Hr4(0,0,-1,0)*dm - 256.D0* & + & Hr4(0,0,0,0) + 448.D0*Hr4(0,0,0,0)*x - 128.D0*Hr4(0,0,0,0)* & + & x**2 + 64.D0*Hr4(0,0,0,0)*dp + 64.D0*Hr4(0,0,0,0)*dm - 96.D0* & + & Hr4(0,0,0,1) + 416.D0*Hr4(0,0,0,1)*x - 256.D0*Hr4(0,0,0,1)* & + & x**2 + 128.D0*Hr4(0,0,0,1)*dp + 128.D0*Hr4(0,0,0,1)*dm - 128.D& + & 0*Hr4(0,0,1,0) + 384.D0*Hr4(0,0,1,0)*x - 192.D0*Hr4(0,0,1,0)* & + & x**2 + 128.D0*Hr4(0,0,1,0)*dx + 32.D0*Hr4(0,0,1,0)*dp + 160.D0& + & *Hr4(0,0,1,0)*dm - 256.D0*Hr4(0,0,1,1) + 128.D0*Hr4(0,0,1,1)* & + & x - 128.D0*Hr4(0,0,1,1)*x**2 + 128.D0*Hr4(0,0,1,1)*dx + 128.D0& + & *Hr4(0,0,1,1)*dm - 160.D0*Hr4(0,1,0,0) + 320.D0*Hr4(0,1,0,0)* & + & x - 160.D0*Hr4(0,1,0,0)*x**2 + 160.D0*Hr4(0,1,0,0)*dx + 160.D0& + & *Hr4(0,1,0,0)*dm ) + ggg2 = ggg2 + ca**3 * ( - 256.D0*Hr4(0,1,0,1) + 128.D0*Hr4(0,1,0 & + & ,1)*x - 128.D0*Hr4(0,1,0,1)*x**2 + 128.D0*Hr4(0,1,0,1)*dx + & + & 128.D0*Hr4(0,1,0,1)*dm - 256.D0*Hr4(0,1,1,0) + 128.D0*Hr4(0,1 & + & ,1,0)*x - 128.D0*Hr4(0,1,1,0)*x**2 + 128.D0*Hr4(0,1,1,0)*dx & + & + 128.D0*Hr4(0,1,1,0)*dm + 128.D0*Hr4(1,0,-1,0) - 64.D0*Hr4( & + & 1,0,-1,0)*x + 64.D0*Hr4(1,0,-1,0)*x**2 - 64.D0*Hr4(1,0,-1,0)* & + & dx - 64.D0*Hr4(1,0,-1,0)*dm - 256.D0*Hr4(1,0,0,0) + 128.D0* & + & Hr4(1,0,0,0)*x - 128.D0*Hr4(1,0,0,0)*x**2 + 128.D0*Hr4(1,0,0, & + & 0)*dx + 128.D0*Hr4(1,0,0,0)*dm - 256.D0*Hr4(1,0,0,1) + 128.D0 & + & *Hr4(1,0,0,1)*x - 128.D0*Hr4(1,0,0,1)*x**2 + 128.D0*Hr4(1,0,0 & + & ,1)*dx + 128.D0*Hr4(1,0,0,1)*dm - 256.D0*Hr4(1,0,1,0) + 128.D0& + & *Hr4(1,0,1,0)*x - 128.D0*Hr4(1,0,1,0)*x**2 + 128.D0*Hr4(1,0,1 & + & ,0)*dx + 128.D0*Hr4(1,0,1,0)*dm - 256.D0*Hr4(1,1,0,0) + 128.D0& + & *Hr4(1,1,0,0)*x - 128.D0*Hr4(1,1,0,0)*x**2 + 128.D0*Hr4(1,1,0 & + & ,0)*dx + 128.D0*Hr4(1,1,0,0)*dm ) + ggg2 = ggg2 + nf*ca**2 * ( - 2174.D0/9.D0 + 7358.D0/27.D0*x - & + & 19264.D0/81.D0*x**2 + 19264.D0/81.D0*dx - 836.D0/27.D0*dm + & + & 496.D0/3.D0*z3 + 112.D0/3.D0*z3*x + 128.D0/3.D0*z3*x**2 - 176.& + & D0/3.D0*z3*dx - 128.D0/3.D0*z3*dm - 1700.D0/9.D0*z2 + 1076.D0/& + & 9.D0*z2*x - 176.D0/3.D0*z2*x**2 - 128.D0/3.D0*z2*dx + 160.D0/ & + & 9.D0*z2*dp + 160.D0/9.D0*z2*dm + 276.D0/5.D0*z2**2 + 156.D0/5.& + & D0*z2**2*x - 88.D0*Hr1(-1)*z2 - 88.D0*Hr1(-1)*z2*x + 16.D0/3.D& + & 0*Hr1(-1)*z2*x**2 + 16.D0/3.D0*Hr1(-1)*z2*dx + 7472.D0/27.D0* & + & Hr1(0) - 3958.D0/27.D0*Hr1(0)*x + 2612.D0/9.D0*Hr1(0)*x**2 + & + & 1136.D0/27.D0*Hr1(0)*dx - 8.D0/3.D0*Hr1(0)*dm - 96.D0*Hr1(0)* & + & z3*x - 4.D0/3.D0*Hr1(0)*z2 + 140.D0/3.D0*Hr1(0)*z2*x + 32.D0/ & + & 3.D0*Hr1(0)*z2*x**2 - 32.D0/3.D0*Hr1(0)*z2*dx + 16.D0/3.D0* & + & Hr1(0)*z2*dp + 1354.D0/9.D0*Hr1(1) - 1354.D0/9.D0*Hr1(1)*x - & + & 820.D0/27.D0*Hr1(1)*x**2 + 820.D0/27.D0*Hr1(1)*dx - 56.D0* & + & Hr1(1)*z2 + 56.D0*Hr1(1)*z2*x + 16.D0*Hr1(1)*z2*x**2 - 16.D0* & + & Hr1(1)*z2*dx ) + ggg2 = ggg2 + nf*ca**2 * ( 1208.D0/9.D0*Hr2(-1,0) + 1528.D0/9.D0* & + & Hr2(-1,0)*x - 304.D0/3.D0*Hr2(-1,0)*x**2 - 304.D0/3.D0*Hr2(-1 & + & ,0)*dx + 320.D0/9.D0*Hr2(-1,0)*dp - 48.D0*Hr2(0,-1)*z2 + 48.D0& + & *Hr2(0,-1)*z2*x - 208.D0/9.D0*Hr2(0,0) - 2420.D0/9.D0*Hr2(0,0 & + & )*x + 496.D0/9.D0*Hr2(0,0)*x**2 - 160.D0/9.D0*Hr2(0,0)*dp - & + & 160.D0/9.D0*Hr2(0,0)*dm - 24.D0*Hr2(0,0)*z2 - 40.D0*Hr2(0,0)* & + & z2*x + 1700.D0/9.D0*Hr2(0,1) + 452.D0/9.D0*Hr2(0,1)*x + 176.D0& + & /3.D0*Hr2(0,1)*x**2 - 176.D0/3.D0*Hr2(0,1)*dx - 320.D0/9.D0* & + & Hr2(0,1)*dm - 48.D0*Hr2(0,1)*z2 - 48.D0*Hr2(0,1)*z2*x + 784.D0& + & /9.D0*Hr2(1,0) - 464.D0/9.D0*Hr2(1,0)*x + 176.D0/3.D0*Hr2(1,0 & + & )*x**2 - 176.D0/3.D0*Hr2(1,0)*dx - 320.D0/9.D0*Hr2(1,0)*dm - & + & 112.D0*Hr3(-1,-1,0) - 112.D0*Hr3(-1,-1,0)*x + 32.D0*Hr3(-1,-1 & + & ,0)*x**2 + 32.D0*Hr3(-1,-1,0)*dx + 72.D0*Hr3(-1,0,0) + 72.D0* & + & Hr3(-1,0,0)*x - 32.D0/3.D0*Hr3(-1,0,0)*x**2 - 32.D0/3.D0*Hr3( & + & -1,0,0)*dx + 32.D0*Hr3(-1,0,1) + 32.D0*Hr3(-1,0,1)*x + 32.D0/ & + & 3.D0*Hr3(-1,0,1)*x**2 ) + ggg2 = ggg2 + nf*ca**2 * ( 32.D0/3.D0*Hr3(-1,0,1)*dx + 440.D0/3.D0& + & *Hr3(0,-1,0) - 24.D0*Hr3(0,-1,0)*x - 64.D0/3.D0*Hr3(0,-1,0)* & + & x**2 - 32.D0/3.D0*Hr3(0,-1,0)*dx - 32.D0/3.D0*Hr3(0,-1,0)*dm & + & + 32.D0*Hr3(0,0,0) - 152.D0/3.D0*Hr3(0,0,0)*x + 4.D0/3.D0* & + & Hr3(0,0,1) - 212.D0/3.D0*Hr3(0,0,1)*x - 32.D0/3.D0*Hr3(0,0,1) & + & *x**2 - 16.D0/3.D0*Hr3(0,0,1)*dm - 32.D0/3.D0*Hr3(0,1,0) - 32.& + & D0/3.D0*Hr3(0,1,0)*x + 116.D0/3.D0*Hr3(1,0,0) - 100.D0/3.D0* & + & Hr3(1,0,0)*x - 16.D0/3.D0*Hr3(1,0,0)*dm - 96.D0*Hr4(0,-1,-1,0 & + & ) + 96.D0*Hr4(0,-1,-1,0)*x + 48.D0*Hr4(0,-1,0,0) - 48.D0*Hr4( & + & 0,-1,0,0)*x + 80.D0*Hr4(0,0,-1,0) - 16.D0*Hr4(0,0,-1,0)*x + & + & 16.D0*Hr4(0,0,0,0)*x + 24.D0*Hr4(0,0,0,1) + 24.D0*Hr4(0,0,0,1 & + & )*x + 24.D0*Hr4(0,1,0,0) + 24.D0*Hr4(0,1,0,0)*x ) + ggg2 = ggg2 + nf*cf*ca * ( 19204.D0/27.D0 + 182.D0/27.D0*x - & + & 24526.D0/81.D0*x**2 - 30662.D0/81.D0*dx - 110.D0/3.D0*dm - & + & 464.D0/3.D0*z3 - 1208.D0/3.D0*z3*x + 32.D0/3.D0*z3*x**2 + 224.& + & D0/3.D0*z3*dx + 32.D0*z3*dm + 2696.D0/9.D0*z2 - 3964.D0/9.D0* & + & z2*x - 160.D0/9.D0*z2*x**2 + 608.D0/9.D0*z2*dx - 664.D0/5.D0* & + & z2**2 - 344.D0/5.D0*z2**2*x + 208.D0*Hr1(-1)*z2 + 208.D0*Hr1( & + & -1)*z2*x - 64.D0/3.D0*Hr1(-1)*z2*x**2 - 64.D0/3.D0*Hr1(-1)*z2 & + & *dx + 3220.D0/27.D0*Hr1(0) + 13804.D0/27.D0*Hr1(0)*x + 112.D0 & + & *Hr1(0)*x**2 - 1376.D0/27.D0*Hr1(0)*dx - 16.D0*Hr1(0)*z3 + & + & 144.D0*Hr1(0)*z3*x + 64.D0/3.D0*Hr1(0)*z2 - 488.D0/3.D0*Hr1(0 & + & )*z2*x - 32.D0*Hr1(0)*z2*x**2 + 64.D0/3.D0*Hr1(0)*z2*dx - & + & 2264.D0/9.D0*Hr1(1) + 3428.D0/9.D0*Hr1(1)*x - 1408.D0/27.D0* & + & Hr1(1)*x**2 - 2084.D0/27.D0*Hr1(1)*dx + 144.D0*Hr1(1)*z2 - & + & 144.D0*Hr1(1)*z2*x - 128.D0/3.D0*Hr1(1)*z2*x**2 + 128.D0/3.D0 & + & *Hr1(1)*z2*dx - 1232.D0/3.D0*Hr2(-1,0) - 1520.D0/3.D0*Hr2(-1, & + & 0)*x ) + ggg2 = ggg2 + nf*cf*ca * ( - 160.D0/9.D0*Hr2(-1,0)*x**2 + 704.D0/& + & 9.D0*Hr2(-1,0)*dx + 128.D0*Hr2(0,-1)*z2 - 128.D0*Hr2(0,-1)*z2 & + & *x + 4028.D0/9.D0*Hr2(0,0) + 4832.D0/9.D0*Hr2(0,0)*x + 1016.D0& + & /9.D0*Hr2(0,0)*x**2 + 96.D0*Hr2(0,0)*z2 + 96.D0*Hr2(0,0)*z2*x & + & - 2696.D0/9.D0*Hr2(0,1) - 596.D0/9.D0*Hr2(0,1)*x + 160.D0/9.D& + & 0*Hr2(0,1)*x**2 + 32.D0/3.D0*Hr2(0,1)*dx + 128.D0*Hr2(0,1)*z2 & + & + 128.D0*Hr2(0,1)*z2*x - 256.D0/3.D0*Hr2(1,0) + 112.D0/3.D0* & + & Hr2(1,0)*x + 296.D0/9.D0*Hr2(1,0)*x**2 + 136.D0/9.D0*Hr2(1,0) & + & *dx + 12.D0*Hr2(1,1) - 12.D0*Hr2(1,1)*x - 16.D0/9.D0*Hr2(1,1) & + & *x**2 + 16.D0/9.D0*Hr2(1,1)*dx + 288.D0*Hr3(-1,-1,0) + 288.D0 & + & *Hr3(-1,-1,0)*x - 256.D0/3.D0*Hr3(-1,-1,0)*x**2 - 256.D0/3.D0 & + & *Hr3(-1,-1,0)*dx - 144.D0*Hr3(-1,0,0) - 144.D0*Hr3(-1,0,0)*x & + & - 32.D0/3.D0*Hr3(-1,0,0)*x**2 - 32.D0/3.D0*Hr3(-1,0,0)*dx - & + & 64.D0*Hr3(-1,0,1) - 64.D0*Hr3(-1,0,1)*x - 64.D0/3.D0*Hr3(-1,0 & + & ,1)*x**2 - 64.D0/3.D0*Hr3(-1,0,1)*dx - 208.D0*Hr3(0,-1,0) - & + & 112.D0*Hr3(0,-1,0)*x ) + ggg2 = ggg2 + nf*cf*ca * ( 64.D0*Hr3(0,-1,0)*x**2 + 64.D0/3.D0* & + & Hr3(0,-1,0)*dx + 232.D0/3.D0*Hr3(0,0,0) - 560.D0/3.D0*Hr3(0,0 & + & ,0)*x - 64.D0/3.D0*Hr3(0,0,1) + 152.D0/3.D0*Hr3(0,0,1)*x + 32.& + & D0*Hr3(0,0,1)*x**2 - 16.D0/3.D0*Hr3(0,1,0) + 8.D0/3.D0*Hr3(0, & + & 1,0)*x + 32.D0/3.D0*Hr3(0,1,0)*x**2 - 64.D0/3.D0*Hr3(0,1,0)* & + & dx + 88.D0/3.D0*Hr3(0,1,1) + 136.D0/3.D0*Hr3(0,1,1)*x + 32.D0/& + & 3.D0*Hr3(0,1,1)*x**2 - 32.D0/3.D0*Hr3(0,1,1)*dx - 104.D0*Hr3( & + & 1,0,0) + 104.D0*Hr3(1,0,0)*x + 128.D0/3.D0*Hr3(1,0,0)*x**2 - & + & 128.D0/3.D0*Hr3(1,0,0)*dx - 16.D0*Hr3(1,1,0) + 16.D0*Hr3(1,1, & + & 0)*x + 64.D0/3.D0*Hr3(1,1,0)*x**2 - 64.D0/3.D0*Hr3(1,1,0)*dx & + & - 16.D0*Hr3(1,1,1) + 16.D0*Hr3(1,1,1)*x + 64.D0/3.D0*Hr3(1,1 & + & ,1)*x**2 - 64.D0/3.D0*Hr3(1,1,1)*dx + 256.D0*Hr4(0,-1,-1,0) & + & - 256.D0*Hr4(0,-1,-1,0)*x - 64.D0*Hr4(0,-1,0,0) + 64.D0*Hr4( & + & 0,-1,0,0)*x - 128.D0*Hr4(0,0,-1,0) + 128.D0*Hr4(0,0,0,0) - & + & 192.D0*Hr4(0,0,0,0)*x - 96.D0*Hr4(0,0,0,1) - 96.D0*Hr4(0,0,0, & + & 1)*x ) + ggg2 = ggg2 + nf*cf*ca * ( - 64.D0*Hr4(0,0,1,0) - 64.D0*Hr4(0,0, & + & 1,0)*x - 16.D0*Hr4(0,0,1,1) - 16.D0*Hr4(0,0,1,1)*x - 112.D0* & + & Hr4(0,1,0,0) - 112.D0*Hr4(0,1,0,0)*x - 32.D0*Hr4(0,1,1,0) - & + & 32.D0*Hr4(0,1,1,0)*x - 32.D0*Hr4(0,1,1,1) - 32.D0*Hr4(0,1,1,1 & + & )*x ) + ggg2 = ggg2 + nf*cf**2 * ( - 850.D0/3.D0 + 66.D0*x + 232.D0*x**2 & + & - 44.D0/3.D0*dx - 32.D0*z3*x - 256.D0/3.D0*z3*x**2 + 64.D0/3.& + & D0*z3*dx - 64.D0*z2 + 1012.D0/3.D0*z2*x - 64.D0/3.D0*z2*x**2 & + & + 104.D0*z2**2 + 72.D0*z2**2*x - 64.D0*Hr1(-1)*z2 - 64.D0* & + & Hr1(-1)*z2*x + 64.D0/3.D0*Hr1(-1)*z2*x**2 + 64.D0/3.D0*Hr1(-1 & + & )*z2*dx - 254.D0*Hr1(0) - 1082.D0/3.D0*Hr1(0)*x + 72.D0*Hr1(0 & + & )*x**2 + 112.D0*Hr1(0)*z3 - 16.D0*Hr1(0)*z3*x + 64.D0*Hr1(0)* & + & z2 + 80.D0*Hr1(0)*z2*x + 88.D0/3.D0*Hr1(1) - 428.D0/3.D0*Hr1( & + & 1)*x + 72.D0*Hr1(1)*x**2 + 124.D0/3.D0*Hr1(1)*dx - 64.D0*Hr1( & + & 1)*z2 + 64.D0*Hr1(1)*z2*x + 64.D0/3.D0*Hr1(1)*z2*x**2 - 64.D0/& + & 3.D0*Hr1(1)*z2*dx + 1072.D0/3.D0*Hr2(-1,0) + 1072.D0/3.D0* & + & Hr2(-1,0)*x - 64.D0*Hr2(0,-1)*z2 + 64.D0*Hr2(0,-1)*z2*x - 328.& + & D0/3.D0*Hr2(0,0) - 396.D0*Hr2(0,0)*x + 224.D0/3.D0*Hr2(0,0)* & + & x**2 + 32.D0*Hr2(0,0)*z2 + 32.D0*Hr2(0,0)*z2*x + 64.D0*Hr2(0, & + & 1) + 20.D0*Hr2(0,1)*x + 64.D0/3.D0*Hr2(0,1)*x**2 - 64.D0*Hr2( & + & 0,1)*z2 ) + ggg2 = ggg2 + nf*cf**2 * ( - 64.D0*Hr2(0,1)*z2*x - 184.D0/3.D0* & + & Hr2(1,0) + 40.D0/3.D0*Hr2(1,0)*x + 224.D0/3.D0*Hr2(1,0)*x**2 & + & - 80.D0/3.D0*Hr2(1,0)*dx - 28.D0/3.D0*Hr2(1,1) + 28.D0/3.D0* & + & Hr2(1,1)*x + 64.D0/3.D0*Hr2(1,1)*x**2 - 64.D0/3.D0*Hr2(1,1)* & + & dx - 128.D0*Hr3(-1,-1,0) - 128.D0*Hr3(-1,-1,0)*x + 128.D0/3.D0& + & *Hr3(-1,-1,0)*x**2 + 128.D0/3.D0*Hr3(-1,-1,0)*dx + 64.D0*Hr3( & + & -1,0,0) + 64.D0*Hr3(-1,0,0)*x - 64.D0/3.D0*Hr3(-1,0,0)*x**2 & + & - 64.D0/3.D0*Hr3(-1,0,0)*dx + 128.D0*Hr3(0,-1,0) - 128.D0/3.D& + & 0*Hr3(0,-1,0)*x**2 - 24.D0*Hr3(0,0,0) - 88.D0*Hr3(0,0,0)*x + & + & 32.D0/3.D0*Hr3(0,0,0)*x**2 - 64.D0*Hr3(0,0,1) - 80.D0*Hr3(0,0 & + & ,1)*x - 80.D0*Hr3(0,1,0) - 128.D0*Hr3(0,1,0)*x - 64.D0/3.D0* & + & Hr3(0,1,0)*x**2 - 48.D0*Hr3(0,1,1) - 64.D0*Hr3(0,1,1)*x - 64.D& + & 0/3.D0*Hr3(0,1,1)*x**2 + 56.D0*Hr3(1,0,0) - 56.D0*Hr3(1,0,0)* & + & x - 32.D0/3.D0*Hr3(1,0,0)*x**2 + 32.D0/3.D0*Hr3(1,0,0)*dx + & + & 16.D0*Hr3(1,1,0) - 16.D0*Hr3(1,1,0)*x - 64.D0/3.D0*Hr3(1,1,0) & + & *x**2 ) + ggg2 = ggg2 + nf*cf**2 * ( 64.D0/3.D0*Hr3(1,1,0)*dx + 16.D0*Hr3(1 & + & ,1,1) - 16.D0*Hr3(1,1,1)*x - 64.D0/3.D0*Hr3(1,1,1)*x**2 + 64.D& + & 0/3.D0*Hr3(1,1,1)*dx - 128.D0*Hr4(0,-1,-1,0) + 128.D0*Hr4(0, & + & -1,-1,0)*x + 64.D0*Hr4(0,-1,0,0) - 64.D0*Hr4(0,-1,0,0)*x + & + & 128.D0*Hr4(0,0,-1,0) - 32.D0*Hr4(0,0,0,0) - 32.D0*Hr4(0,0,0,0 & + & )*x - 32.D0*Hr4(0,0,0,1) - 32.D0*Hr4(0,0,0,1)*x + 16.D0*Hr4(0 & + & ,0,1,1) + 16.D0*Hr4(0,0,1,1)*x + 48.D0*Hr4(0,1,0,0) + 48.D0* & + & Hr4(0,1,0,0)*x + 32.D0*Hr4(0,1,1,0) + 32.D0*Hr4(0,1,1,0)*x + & + & 32.D0*Hr4(0,1,1,1) + 32.D0*Hr4(0,1,1,1)*x ) + ggg2 = ggg2 + nf2*ca * ( - 110.D0/27.D0 + 14.D0/3.D0*x - 472.D0 & + & /81.D0*x**2 + 472.D0/81.D0*dx - 16.D0/27.D0*dm + 32.D0/9.D0* & + & z2 + 32.D0/9.D0*z2*x + 152.D0/27.D0*Hr1(0) + 86.D0/27.D0*Hr1( & + & 0)*x + 104.D0/27.D0*Hr1(0)*x**2 + 22.D0/9.D0*Hr1(1) - 22.D0/9.& + & D0*Hr1(1)*x + 104.D0/27.D0*Hr1(1)*x**2 - 104.D0/27.D0*Hr1(1)* & + & dx - 16.D0/9.D0*Hr2(0,0) - 16.D0/9.D0*Hr2(0,0)*x - 32.D0/9.D0 & + & *Hr2(0,1) - 32.D0/9.D0*Hr2(0,1)*x ) + ggg2 = ggg2 + nf2*cf * ( 224.D0/9.D0 + 64.D0/9.D0*x - 1360.D0/ & + & 81.D0*x**2 - 1232.D0/81.D0*dx - 16.D0/3.D0*z3 - 16.D0/3.D0*z3 & + & *x + 16.D0/9.D0*z2 + 64.D0/9.D0*z2*x - 32.D0/9.D0*z2*x**2 - & + & 352.D0/27.D0*Hr1(0) + 1088.D0/27.D0*Hr1(0)*x + 176.D0/27.D0* & + & Hr1(0)*x**2 + 32.D0/3.D0*Hr1(0)*z2 + 32.D0/3.D0*Hr1(0)*z2*x & + & - 104.D0/3.D0*Hr1(1) + 56.D0/3.D0*Hr1(1)*x + 176.D0/27.D0* & + & Hr1(1)*x**2 + 256.D0/27.D0*Hr1(1)*dx + 184.D0/9.D0*Hr2(0,0) & + & + 232.D0/9.D0*Hr2(0,0)*x + 64.D0/9.D0*Hr2(0,0)*x**2 - 16.D0/ & + & 9.D0*Hr2(0,1) - 64.D0/9.D0*Hr2(0,1)*x + 32.D0/9.D0*Hr2(0,1)* & + & x**2 - 16.D0/3.D0*Hr2(1,0) + 16.D0/3.D0*Hr2(1,0)*x + 64.D0/9.D& + & 0*Hr2(1,0)*x**2 - 64.D0/9.D0*Hr2(1,0)*dx - 8.D0/3.D0*Hr2(1,1) & + & + 8.D0/3.D0*Hr2(1,1)*x + 32.D0/9.D0*Hr2(1,1)*x**2 - 32.D0/9.D& + & 0*Hr2(1,1)*dx - 16.D0/3.D0*Hr3(0,0,0) - 16.D0/3.D0*Hr3(0,0,0) & + & *x - 32.D0/3.D0*Hr3(0,0,1) - 32.D0/3.D0*Hr3(0,0,1)*x - 32.D0/ & + & 3.D0*Hr3(0,1,0) - 32.D0/3.D0*Hr3(0,1,0)*x - 16.D0/3.D0*Hr3(0, & + & 1,1) ) + ggg2 = ggg2 + nf2*cf * ( - 16.D0/3.D0*Hr3(0,1,1)*x ) +! +! ...The soft (`+'-distribution) part of the splitting function +! + ! GPS: how included from module QCD +! A3G = & +! & ca**3 * ( + 490.D0/3.D0 + 88.D0/3.D0*z3 - 1072.D0/9.D0*z2& +! & + 176.D0/5.D0*z2**2 ) & +! & + ca**2*nf * ( - 836./27.D0 + 160./9.D0*z2 - 112./3.D0*z3 ) & +! & + ca*cf*nf * ( - 110./3.D0 + 32.*z3 ) - ca*nf2 * 16./27.D0 +! + GGG2L = DM * A3G +! +! ...The regular piece of the splitting function +! + X2GGA = GGG2 - GGG2L +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The singular (soft) piece of P_gg^(2). +! + FUNCTION X2GGB (Y, NF) + IMPLICIT REAL*8 (A - Z) + INTEGER NF +! +! COMMON / P2GSOFT / A3G +! + X2GGB = A3G/(1.D0-Y) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The 'local' piece of P_gg^(2). +! + FUNCTION X2GGC (Y, NF) +! + IMPLICIT REAL*8 (A - Z) + INTEGER NF, NF2 + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0, & + & Z5 = 1.0369 27755 14336 99263 D0 ) +! +! COMMON / P2GSOFT / A3G +! +! ...Colour factors +! + !CF = 4./3.D0 + !CA = 3.D0 + NF2 = NF*NF +! +! ...The coefficient of delta(1-x) +! + P2GDELT = & + & + 79.D0/2.D0*ca**3 & + & + 8.D0/3.D0*z2*ca**3 & + & + 22.D0/3.D0*z2**2*ca**3 & + & + 536.D0/3.D0*z3*ca**3 & + & - 16.D0*z2*z3*ca**3 & + & - 80.D0*z5*ca**3 & + & + cf**2*nf & + & - 233.D0/18*ca**2*nf & + & - 8.D0/3.D0*z2*ca**2*nf & + & - 80.D0/3.D0*z3*ca**2*nf & + & - 4.D0/3.D0*z2**2*ca**2*nf & + & - 241.D0/18.D0*ca*cf*nf & + & + 29.D0/18.D0*ca*nf2 & + & + 11.D0/9.D0*cf*nf2 +! + X2GGC = LOG (1.D0-Y) * A3G + P2GDELT +! + RETURN + END FUNCTION + end module xpij2e diff --git a/src/xpij2n.f90 b/src/xpij2n.f90 new file mode 100644 index 0000000..060d5c5 --- /dev/null +++ b/src/xpij2n.f90 @@ -0,0 +1,233 @@ +! $Id: xpij2n.f90,v 1.3 2004/06/01 09:30:21 salam Exp $ +! Automatically generated from f77 file, with addition of "d0" +! and the placement inside a module. +module xpij2n +character(len=*), parameter :: name_xpij2 = "xpij2n" +contains +! +! ..File: xpij2n.f UPDATE 7/2000 +! +! +! ..Parametrisation of the 3-loop MS(bar) splitting functions P_ij^(2) +! for the evolution of unpolarized singlet partons at mu_r = mu_f. +! The expansion parameter is alpha_s/(4 pi). +! +! ..The two sets providing the error estimate are called via IMOD = 1 +! and IMOD = 2.0d0 Any other value of IMOD invokes their average. +! +! ..The distributions (in the mathematical sense) are given as in eq. +! (B.27) of Floratos, Kounnas, Lacaze: Nucl. Phys. B192 (1981) 417.0d0 +! The name-endings A, B, and C of the functions below correspond to +! the kernel superscripts [2], [3], and [1] in that equation. +! +! ..The results are based on the lowest six even-integer moments +! calculated by Larin et al. and Retey and Vermaseren, supplemented +! by the leading small-x terms obtained by Catani and Hautmann, +! Fadin and Lipatov, and Camici and Ciafaloni. +! +! ..Reference: W.L. van Neerven and A. Vogt, +! hep-ph/9907472 (non-singlet, needed for P_qq), +! hep-ph/0006154, and hep-ph/0007362 +! It is appropriate to cite also the sources of information, i.e, +! refs. [2-9] of hep-ph/0007362.0d0 +! +! +! ===================================================================== +! +! +! ..This is the (regular) pure-singlet splitting functions P_ps^(2). +! P_qq^(2) is obtained by adding the non-singlet quantity P_NS^(2)+. +! + FUNCTION P2PSA (Y, NF, IMOD) +! + IMPLICIT REAL*8 (A-Z) + DIMENSION CL3(2) + INTEGER IMOD, NF + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + G2PSA1 = (229.497d0 * DL1 + 722.99d0 * Y**2 - 2678.77d0 + 560.20d0/Y) & + & * (1.0d0-Y) - 2008.61d0 * DL - 998.15d0 * DL**2 + G2PSA2 = (-73.845d0 * DL1**2 - 305.988d0 * DL1 - 2063.19d0 * Y & + & + 387.95d0/Y ) * (1.0d0-Y) - 1999.35d0 * Y*DL + 732.68d0 * DL +! + IF (IMOD .EQ. 1) THEN + G2PSA = G2PSA1 + ELSE IF (IMOD .EQ. 2) THEN + G2PSA = G2PSA2 + ELSE + G2PSA = 0.5d0 * (G2PSA1 + G2PSA2) + END IF +! + G2PSA = G2PSA + 3584.0d0/(27.0d0* Y) * DL & + & + NF * ( (7.282d0 * DL1 + 38.779d0 * Y**2 - 32.022d0 * Y & + & + 6.252d0 - 1.767d0 / Y ) * (1.0d0-Y) -7.453d0 * DL**2 ) + P2PSA = - NF * G2PSA +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the gluon->quark splitting functions P_qg^(2). +! + FUNCTION P2QGA (Y, NF, IMOD) +! + IMPLICIT REAL*8 (A-Z) + DIMENSION CL3(2) + INTEGER IMOD, NF + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + G2QGA1 = 31.830d0 * DL1**3 - 1252.267d0 * DL1 - 1722.47d0 & + & - 1999.89d0 * Y - 1223.43d0 * DL**2 + 1334.61d0 / Y + G2QGA2 = - 19.428d0 * DL1**4 - 159.833d0*DL1**3-309.384d0*DL1**2 & + & - 2631.00d0 * (1.0d0-Y) + 67.25d0 * DL**2 + 776.793d0 / Y +! + IF (IMOD .EQ. 1) THEN + G2QGA = G2QGA1 + ELSE IF (IMOD .EQ. 2) THEN + G2QGA = G2QGA2 + ELSE + G2QGA = 0.5d0 * (G2QGA1 + G2QGA2) + END IF +! + G2QGA = G2QGA + 896.0d0/ (3.0d0*Y) * DL & + & + NF * ( 0.9085d0 * DL1**2 + 35.803d0 * DL1 + 128.023d0 & + & - 200.929d0*(1.0d0-Y)-40.542d0*DL-3.284d0 / Y) + P2QGA = - NF * G2QGA +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the quark->gluon splitting functions P_gq^(2). +! + FUNCTION P2GQA (Y, NF, IMOD) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMOD, NF + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + G2GQA1 = -13.1212d0 * DL1**4 - 126.665d0 * DL1**3 - 308.536d0 * DL1**2 & + & - 361.21d0 + 2113.45d0 * DL + 17.965d0 * DL/Y & + & + NF* (- 2.4427d0 * DL1**4 - 27.763d0 * DL1**3 - 80.548d0 * DL1**2 & + & +227.135d0 + 151.04d0 * DL**2 - 65.91d0 * DL/Y ) + G2GQA2 = 4.5107d0 * DL1**4 + 66.618d0 * DL1**3 + 231.535d0 * DL1**2 & + & + 1224.22d0* (1.0d0-Y) - 240.08d0 * DL**2 - 379.60d0 * (DL+4.0d0)/Y & + & + NF* (1.4028d0 * DL1**4 + 11.638d0 * DL1**3 - 164.963d0 * DL1 & + & + 1066.78d0* (1.0d0-Y) + 182.08d0 * DL**2 - 138.54d0 * (DL+2.0d0)/Y) +! + IF (IMOD .EQ. 1) THEN + G2GQA = G2GQA1 + ELSE IF (IMOD .EQ. 2) THEN + G2GQA = G2GQA2 + ELSE + G2GQA = 0.5d0 * (G2GQA1 + G2GQA2) + END IF +! + G2GQA = G2GQA & + & + NF**2* (- 1.9361d0 * DL1**2 - 11.178d0 * DL1 - 11.632d0 & + & + 15.145d0 * (1.0d0-Y) - 3.354d0 * DL + 2.133d0 / Y ) + P2GQA = - G2GQA +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the regular piece of the gg splitting function P_gg^(2). +! + FUNCTION P2GGA (Y, NF, IMOD) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMOD, NF + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + G2GGA1 = 732.715d0 * DL1**2 + 20640.069d0 * Y + 15428.58d0 * (1.0d0-Y**2) & + & + 15213.6d0 * DL**2 - 16700.88d0 * 1.0d0/Y & + & + NF* (425.708d0 * DL1 - 914.548d0 * Y**2 + 1122.86d0 & + & + 444.21d0 * DL**2 - 376.98d0 * 1.0d0/Y ) + G2GGA2 = - 3748.934d0 * DL1 + 35974.45d0 * (1.0d0+Y**2) - 60879.62d0 * Y & + & - 2002.96d0 * DL**2 - 9762.09d0 * 1.0d0/Y & + & + NF* (- 62.630d0 * DL1**2 - 801.90d0 - 1891.40d0 * DL & + & - 813.78d0 * DL**2 - 1.360d0 * 1.0d0/Y ) +! + IF (IMOD .EQ. 1) THEN + G2GGA = G2GGA1 + ELSE IF (IMOD .EQ. 2) THEN + G2GGA = G2GGA2 + ELSE + G2GGA = 0.5d0 * (G2GGA1 + G2GGA2) + END IF +! + G2GGA = G2GGA - (2675.85d0 + NF * 157.18d0) * DL / Y & + & + NF**2 * (- 37.6417d0 * Y**2 + 72.926d0 * Y - 32.349d0 & + & + 0.991d0 * DL**2 - 2.818d0 / Y ) + P2GGA = - G2GGA +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the singular piece of the gg splitting function P_gg^(2). +! + FUNCTION P2GGB (Y, NF, IMOD) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMOD, NF + D1 = 1.0d0/(1.0d0-Y) +! + G2GGB1 = (-2626.38d0 + NF * 415.71d0) * D1 + G2GGB2 = (-2678.22d0 + NF * 412.00d0) * D1 +! + IF (IMOD .EQ. 1) THEN + G2GGB = G2GGB1 + ELSE IF (IMOD .EQ. 2) THEN + G2GGB = G2GGB2 + ELSE + G2GGB = 0.5d0 * (G2GGB1 + G2GGB2) + END IF +! + G2GGB = G2GGB + NF**2 * 16.0d0/9.0d0 * D1 + P2GGB = -G2GGB +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the 'local' piece of the gg splitting function P_gg^(2). +! + FUNCTION P2GGC (Y, NF, IMOD) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMOD, NF + DL1 = LOG (1.0d0-Y) +! + G2GGC1 = (-2626.38d0 + NF * 415.71d0)* DL1 - 4424.168d0 + NF * 548.569d0 + G2GGC2 = (-2678.22d0 + NF * 412.00d0)* DL1 - 4590.570d0 + NF * 534.951d0 +! + IF (IMOD .EQ. 1) THEN + G2GGC = G2GGC1 + ELSE IF (IMOD .EQ. 2) THEN + G2GGC = G2GGC2 + ELSE + G2GGC = 0.5d0 * (G2GGC1 + G2GGC2) + END IF +! + G2GGC = G2GGC + NF**2 * (16.0d0/9.0d0 * DL1 - 6.4882d0) + P2GGC = -G2GGC +! + RETURN + END FUNCTION +end module xpij2n diff --git a/src/xpij2p.f90 b/src/xpij2p.f90 new file mode 100644 index 0000000..454bbed --- /dev/null +++ b/src/xpij2p.f90 @@ -0,0 +1,191 @@ +! $Id: xpij2p.f90,v 1.1 2004/06/01 09:30:23 salam Exp $ +! Automatically generated from f77 file, with addition of "d0" +! and the placement inside a module. +module xpij2p +character(len=*), parameter :: name_xpij2 = "xpij2p" +contains +! +! ..File: xpij2p.f +! +! __ +! ..The parametrized 3-loop MS singlet splitting functions P^(2) for +! the evolution of unpol. singlet parton densities at mu_r = mu_f. +! The expansion parameter is alpha_s/(4 pi). +! +! ..The distributions (in the mathematical sense) are given as in eq. +! (B.27) of Floratos, Kounnas, Lacaze: Nucl. Phys. B192 (1981) 417.0d0 +! The name-endings A, B, and C of the functions below correspond to +! the kernel superscripts [2], [3], and [1] in that equation. +! +! ..The relative accuracy of these parametrisations, as well as of +! the convolution results, is better than one part in thousand. + +! ..The coefficients of 1/(1-x)_+, (ln x)/x and 1/x are exact (up +! to a truncation of irrational coefficients). Furthermore all +! coefficients written as fractions (e.g., 160.0d0/27.0d0) are exact. +! The other terms at x < 1 have fitted to the exact results for x +! between 10^-6 and 1 - 10^-6.0d0 The coefficient of delta(1-x) of +! P_gg^(2) have been slightly adjusted using the second moments. +! +! ..References: S. Moch, J. Vermaseren and A. Vogt, +! hep-ph/0403192 (to appear in Nucl. Phys. B) +! A. Vogt, S. Moch and J. Vermaseren, +! hep-ph/0404111 (submitted to Nucl. Phys. B) +! +! ===================================================================== +! +! +! ..The (regular) pure-singlet splitting functions P_ps^(2). +! P_qq^(2) is obtained by adding the non-singlet quantity P_NS^(2)+. +! A parametrization of the latter is provided in the file xpns2p.f. + + FUNCTION P2PSA (Y, NF) +! + IMPLICIT REAL*8 (A-Z) + INTEGER NF +! + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + P2PS1 = - 3584.0d0/(27.0d0*Y) * DL - 506.0d0/ Y + 160.0d0/27.0d0 * DL**4 & + & - 400.0d0/9.0d0 * DL**3 + 131.4d0 * DL**2 - 661.6d0 * DL & + & - 5.926d0 * DL1**3 - 9.751d0 * DL1**2 - 72.11d0 * DL1 & + & + 177.4d0 + 392.9d0 * Y - 101.4d0 * Y**2 - 57.04d0 * DL*DL1 + P2PS2 = 256.0d0/(81.0d0*Y) + 32.0d0/27.0d0 * DL**3 + 17.89d0 * DL**2 & + & + 61.75d0 * DL + 1.778d0 * DL1**2 + 5.944d0 * DL1 + 100.1d0 & + & - 125.2d0 * Y + 49.26d0 * Y**2 - 12.59d0 * Y**3 & + & - 1.889d0 * DL*DL1 +! + P2PSA = (1.0d0-Y) * NF * ( P2PS1 + NF * P2PS2 ) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The gluon->quark splitting functions P_qg^(2). +! + FUNCTION P2QGA (Y, NF) +! + IMPLICIT REAL*8 (A-Z) + INTEGER NF +! + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + P2QG1 = - 896.0d0/(3.0d0*Y) * DL - 1268.3d0 / Y + 536.0d0/27.0d0 * DL**4 & + & - 44.0d0/3.0d0 * DL**3 + 881.5d0 * DL**2 + 424.9d0 * DL & + & + 100.0d0/27.0d0 * DL1**4 - 70.0d0/9.0d0 * DL1**3 & + & - 120.5d0 * DL1**2 + 104.42d0 * DL1 & + & + 2522.0d0 - 3316.0d0* Y + 2126.0d0* Y**2 & + & + DL*DL1 * (1823.0d0 - 25.22d0 * DL) - 252.5d0 * Y*DL**3 + P2QG2 = 1112.0d0/(243.0d0*Y) - 16.0d0/9.0d0 * DL**4 & + & - 376.0d0/27.0d0 * DL**3 - 90.8d0 * DL**2 - 254.0d0 * DL & + & + 20.0d0/27.0d0 * DL1**3 + 200.0d0/27.0d0 * DL1**2 - 5.496d0 * DL1 & + & - 252.0d0 + 158.0d0 * Y + 145.4d0 * Y**2 - 139.28d0 * Y**3 & + & - DL*DL1 * ( 53.09d0 + 80.616d0 * DL) - 98.07d0 * Y*DL**2 & + & + 11.70d0 * Y*DL**3 +! + P2QGA = NF * ( P2QG1 + NF * P2QG2 ) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The quark->gluon splitting functions P_gq^(2). P2GQ2 is exact. +! + FUNCTION P2GQA (Y, NF) +! + IMPLICIT REAL*8 (A-Z) + INTEGER NF +! + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + P2GQ0 = 1189.3d0 * DL/Y + 6163.1d0 / Y - 4288.0d0/81.0d0 * DL**4 & + & + 1568.0d0/9.0d0 * DL**3 - 1794.0d0 * DL**2 + 4033.0d0 * DL & + & + 400.0d0/81.0d0 * DL1**4 + 2200.0d0/27.0d0 * DL1**3 & + & + 606.3d0 * DL1**2 + 2193.0d0* DL1 & + & - 4307.0d0 + 489.3d0 * Y + 1452.0d0* Y**2 + 146.0d0 * Y**3 & + & - 447.3d0 * DL**2*DL1 - 972.9d0 * Y*DL**2 + P2GQ1 = 71.082d0 * DL/Y - 46.41d0 / Y + 128.0d0/27.0d0 * DL**4 & + & + 704/81.0d0 * DL**3 + 20.39d0 * DL**2 + 174.8d0 * DL & + & - 400.0d0/81.0d0 * DL1**3 - 68.069d0 * DL1**2 - 296.7d0 * DL1 & + & - 183.8d0 + 33.35d0 * Y - 277.9d0 * Y**2 + 108.6d0 * Y*DL**2 & + & - 49.68d0 * DL*DL1 + P2GQ2 = ( 64.0d0 * ( - 1.0d0/Y + 1.0d0 + 2.0d0* Y) & + & + 320.0d0* DL1 * ( 1.0d0/Y - 1.0d0 + 0.8d0 * Y) & + & + 96.0d0* DL1**2 * ( 1.0d0/Y - 1.0d0 + 0.5d0 * Y) ) / 27.0d0 +! + P2GQA = ( P2GQ0 + NF * (P2GQ1 + NF * P2GQ2) ) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The regular piece of the gluon-gluon splitting function P_gg^(2). +! + FUNCTION P2GGA (Y, NF) +! + IMPLICIT REAL*8 (A-Z) + INTEGER NF +! + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + P2GGA0 = 2675.8d0 * DL/Y + 14214.0d0/ Y - 144.0d0 * DL**4 + 72.0d0 * DL**3 & + & - 7471.0d0 * DL**2 + 274.4d0 * DL + 3589.0d0 * DL1 - 20852.0d0 & + & + 3968.0d0* Y - 3363.0d0 * Y**2 + 4848.0d0 * Y**3 & + & + DL*DL1 * ( 7305.0d0 + 8757.0d0 * DL ) + P2GGA1 = 157.27d0 * DL/Y + 182.96d0 / Y + 512.0d0/27.0d0 * DL**4 & + & + 832.0d0/9.0d0 * DL**3 + 491.3d0 * DL**2 + 1541.0d0 * DL & + & - 320.0d0 * DL1 - 350.2d0 + 755.7d0 * Y - 713.8d0 * Y**2 & + & + 559.3d0 * Y**3 + DL*DL1 * ( 26.15d0 - 808.7d0 * DL ) + P2GGA2 = - 680.0d0/(243.0d0 * Y) - 32.0d0/27.0d0 * DL**3 + 9.680d0 * DL**2 & + & - 3.422d0 * DL - 13.878d0 + 153.4d0 * Y - 187.7d0 * Y**2 & + & + 52.75d0 * Y**3 - DL*DL1 * (115.6d0 - 85.25d0* Y + 63.23d0* DL) +! + P2GGA = P2GGA0 + NF * ( P2GGA1 + NF * P2GGA2 ) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The singular piece of the gluon-gluon splitting function P_gg^(2). +! + FUNCTION P2GGB (Y, NF) +! + IMPLICIT REAL*8 (A-Z) + INTEGER NF +! + P2GGB = ( 2643.521d0 - NF * 412.172d0 - NF**2 * 16.0d0/9.0d0 ) / ( 1.0d0-Y) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..The 'local' piece of the gluon-gluon splitting function P_gg^(2). +! + FUNCTION P2GGC (Y, NF) +! + IMPLICIT REAL*8 (A-Z) + INTEGER NF +! + DL1 = LOG (1.0d0-Y) +! + P2GGC = 2643.521d0 * DL1 + 4425.448d0 + 0.446d0 & + & - NF * ( 412.172d0 * DL1 + 528.720d0 + 0.003d0 ) & + & + NF**2 * ( - 16.0d0/9.0d0 * DL1 + 6.4630d0) +! + RETURN + END FUNCTION +end module xpij2p diff --git a/src/xpns2e.f b/src/xpns2e.f new file mode 100644 index 0000000..cdca4c6 --- /dev/null +++ b/src/xpns2e.f @@ -0,0 +1,766 @@ +! $Id: xpns2e.f,v 1.2 2004/09/18 14:39:38 salam Exp $ +! Automatically generated from f77 file, with inclusion of modules +! and the placement inside a module (and some other stuff). + module xpns2e + use qcd, only: cf, ca, A3 => mvv_A3 + character(len=*), parameter :: name_xpns2 = "xpns2e" + contains +! +! ..File: xpns2e.f +! +! +! ..The exact 3-loop MS(bar) non-singlet splitting functions P_NS^(2) +! for the evolution of unpolarized partons densities, mu_r = mu_f. +! The expansion parameter is alpha_s/(4 pi). +! +! ..The distributions (in the mathematical sense) are given as in eq. +! (B.26) of Floratos, Kounnas, Lacaze: Nucl. Phys. B192 (1981) 417. +! The name-endings A, B, and C of the functions below correspond to +! the kernel superscripts [2], [3], and [1] in that equation. +! +! ..The code uses the package of Gehrmann and Remiddi for the harmonic +! polylogarithms published in hep-ph/0107173 = CPC 141 (2001) 296. +! +! ..References: S. Moch, J. Vermaseren and A. Vogt, +! hep-ph/0209100 = Nucl. Phys. B646 (2002) 181, +! hep-ph/0403192 (submitted to Nucl. Phys. B) +! +! ===================================================================== +! +! +! ..This is the regular piece of P_NS+ +! + FUNCTION X2NSPA (X, NF) +! + IMPLICIT REAL*8 (A - Z) + COMPLEX*16 HC1, HC2, HC3, HC4 + INTEGER NF, NF2, N1, N2, NW, I1, I2, I3, N + PARAMETER ( N1 = -1, N2 = 1, NW = 4 ) + DIMENSION HC1(N1:N2),HC2(N1:N2,N1:N2),HC3(N1:N2,N1:N2,N1:N2), & + & HC4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HR1(N1:N2),HR2(N1:N2,N1:N2),HR3(N1:N2,N1:N2,N1:N2), & + & HR4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HI1(N1:N2),HI2(N1:N2,N1:N2),HI3(N1:N2,N1:N2,N1:N2), & + & HI4(N1:N2,N1:N2,N1:N2,N1:N2) + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0, & + & Z5 = 1.0369 27755 14336 99263 D0 ) +! +! ..The soft coefficient for use in X2NSPB and X2NSPC +! +! COMMON / P2SOFT / A3 +! +! ...Colour factors +! + !CF = 4./3.D0 + !CA = 3.D0 + NF2 = NF*NF +! +! ...Some abbreviations +! + DX = 1.D0/X + DM = 1.D0/(1.D0-X) + DP = 1.D0/(1.D0+X) +! +! ...The harmonic polylogs up to weight 4 by Gehrmann and Remiddi +! + CALL HPLOG (X, NW, HC1,HC2,HC3,HC4, HR1,HR2,HR3,HR4, & + & HI1,HI2,HI3,HI4, N1, N2) +! +! ...The splitting function in terms of the harmonic polylogs +! (without the delta(1-x) part, but with the soft contribution) +! + gqq2 = & + & + cf*ca**2 * ( 5327.D0/27.D0 - 9737.D0/27.D0*x + 490.D0/3.D0*dm & + & - 224.D0*z3*x - 88.D0*z3*dp + 16.D0*z3*dm - 112.D0*z2 + 448.D& + & 0/9.D0*z2*x + 1072.D0/9.D0*z2*dp - 1072.D0/9.D0*z2*dm - 62.D0/& + & 5.D0*z2**2 - 242.D0/5.D0*z2**2*x - 32.D0*z2**2*dp + 384.D0/5.D& + & 0*z2**2*dm - 192.D0*Hr1(-1)*z3 + 192.D0*Hr1(-1)*z3*x + 384.D0 & + & *Hr1(-1)*z3*dp + 208.D0/3.D0*Hr1(-1)*z2 + 560.D0/3.D0*Hr1(-1) & + & *z2*x + 352.D0/3.D0*Hr1(-1)*z2*dp + 410.D0/27.D0*Hr1(0) - & + & 8686.D0/27.D0*Hr1(0)*x - 24.D0*Hr1(0)*dp + 4172.D0/27.D0*Hr1( & + & 0)*dm - 144.D0*Hr1(0)*z3*x - 128.D0*Hr1(0)*z3*dp + 128.D0* & + & Hr1(0)*z3*dm - 4.D0*Hr1(0)*z2 - 148.D0/3.D0*Hr1(0)*z2*x - 16.D& + & 0/3.D0*Hr1(0)*z2*dp - 248.D0/3.D0*Hr1(0)*z2*dm + 176.D0*Hr1(1 & + & ) - 176.D0*Hr1(1)*x - 144.D0*Hr1(1)*z3 - 144.D0*Hr1(1)*z3*x & + & + 288.D0*Hr1(1)*z3*dm + 32.D0*Hr1(1)*z2 - 32.D0*Hr1(1)*z2*x & + & + 256.D0*Hr2(-1,-1)*z2 - 256.D0*Hr2(-1,-1)*z2*x - 512.D0* & + & Hr2(-1,-1)*z2*dp - 688.D0/9.D0*Hr2(-1,0) + 1456.D0/9.D0*Hr2( & + & -1,0)*x ) + gqq2 = gqq2 + cf*ca**2 * ( 2144.D0/9.D0*Hr2(-1,0)*dp - 176.D0* & + & Hr2(-1,0)*z2 + 176.D0*Hr2(-1,0)*z2*x + 352.D0*Hr2(-1,0)*z2*dp & + & - 136.D0*Hr2(0,-1)*z2 + 136.D0*Hr2(0,-1)*z2*x + 256.D0*Hr2(0 & + & ,-1)*z2*dp - 242.D0/9.D0*Hr2(0,0) - 230.D0/3.D0*Hr2(0,0)*x - & + & 1072.D0/9.D0*Hr2(0,0)*dp + 1556.D0/9.D0*Hr2(0,0)*dm + 36.D0* & + & Hr2(0,0)*z2 - 68.D0*Hr2(0,0)*z2*x - 96.D0*Hr2(0,0)*z2*dp + & + & 112.D0*Hr2(0,1) + 112.D0*Hr2(0,1)*x - 40.D0*Hr2(0,1)*z2 + 24.D& + & 0*Hr2(0,1)*z2*x + 64.D0*Hr2(0,1)*z2*dp + 16.D0*Hr2(1,0)*z2 + & + & 16.D0*Hr2(1,0)*z2*x - 32.D0*Hr2(1,0)*z2*dm + 64.D0*Hr3(-1,-1, & + & 0) + 64.D0*Hr3(-1,-1,0)*x - 328.D0/3.D0*Hr3(-1,0,0) - 152.D0/ & + & 3.D0*Hr3(-1,0,0)*x + 176.D0/3.D0*Hr3(-1,0,0)*dp - 112.D0/3.D0 & + & *Hr3(-1,0,1) - 464.D0/3.D0*Hr3(-1,0,1)*x - 352.D0/3.D0*Hr3(-1 & + & ,0,1)*dp - 88.D0/3.D0*Hr3(0,-1,0) + 40.D0/3.D0*Hr3(0,-1,0)*x & + & + 176.D0/3.D0*Hr3(0,-1,0)*dp - 48.D0*Hr3(0,-1,0)*dm - 128.D0/& + & 3.D0*Hr3(0,0,0)*x - 248.D0/3.D0*Hr3(0,0,0)*dp + 248.D0/3.D0* & + & Hr3(0,0,0)*dm ) + gqq2 = gqq2 + cf*ca**2 * ( 4.D0*Hr3(0,0,1) + 188.D0/3.D0*Hr3(0,0, & + & 1)*x + 176.D0/3.D0*Hr3(0,0,1)*dp + 88.D0/3.D0*Hr3(0,0,1)*dm & + & + 12.D0*Hr3(1,0,0) + 76.D0*Hr3(1,0,0)*x - 88.D0*Hr3(1,0,0)* & + & dm - 128.D0*Hr4(-1,-1,0,0) + 128.D0*Hr4(-1,-1,0,0)*x + 256.D0 & + & *Hr4(-1,-1,0,0)*dp - 256.D0*Hr4(-1,-1,0,1) + 256.D0*Hr4(-1,-1 & + & ,0,1)*x + 512.D0*Hr4(-1,-1,0,1)*dp + 48.D0*Hr4(-1,0,0,0) - 48.& + & D0*Hr4(-1,0,0,0)*x - 96.D0*Hr4(-1,0,0,0)*dp + 128.D0*Hr4(-1,0 & + & ,0,1) - 128.D0*Hr4(-1,0,0,1)*x - 256.D0*Hr4(-1,0,0,1)*dp - 80.& + & D0*Hr4(0,-1,-1,0) - 48.D0*Hr4(0,-1,-1,0)*x + 128.D0*Hr4(0,-1, & + & -1,0)*dm + 88.D0*Hr4(0,-1,0,0) - 56.D0*Hr4(0,-1,0,0)*x - 128.D& + & 0*Hr4(0,-1,0,0)*dp - 32.D0*Hr4(0,-1,0,0)*dm + 96.D0*Hr4(0,-1, & + & 0,1) - 160.D0*Hr4(0,-1,0,1)*x - 256.D0*Hr4(0,-1,0,1)*dp + 64.D& + & 0*Hr4(0,-1,0,1)*dm + 8.D0*Hr4(0,0,-1,0) - 40.D0*Hr4(0,0,-1,0) & + & *x - 32.D0*Hr4(0,0,-1,0)*dp + 32.D0*Hr4(0,0,-1,0)*dm + 40.D0* & + & Hr4(0,0,0,0)*x + 32.D0*Hr4(0,0,0,0)*dp - 32.D0*Hr4(0,0,0,0)* & + & dm ) + gqq2 = gqq2 + cf*ca**2 * ( - 36.D0*Hr4(0,0,0,1) + 28.D0*Hr4(0,0, & + & 0,1)*x + 64.D0*Hr4(0,0,0,1)*dp + 32.D0*Hr4(0,0,0,1)*dm + 28.D0& + & *Hr4(0,1,0,0) + 28.D0*Hr4(0,1,0,0)*x - 64.D0*Hr4(0,1,0,0)*dm & + & - 96.D0*Hr4(1,0,-1,0) - 96.D0*Hr4(1,0,-1,0)*x + 192.D0*Hr4(1 & + & ,0,-1,0)*dm + 48.D0*Hr4(1,0,0,0) + 48.D0*Hr4(1,0,0,0)*x - 96.D& + & 0*Hr4(1,0,0,0)*dm - 64.D0*Hr4(1,0,0,1) - 64.D0*Hr4(1,0,0,1)*x & + & + 128.D0*Hr4(1,0,0,1)*dm + 64.D0*Hr4(1,1,0,0) + 64.D0*Hr4(1, & + & 1,0,0)*x - 128.D0*Hr4(1,1,0,0)*dm ) + gqq2 = gqq2 + cf**2*ca * ( 532.D0/9.D0 - 532.D0/9.D0*x - 16.D0/3.D& + & 0*z3 + 2336.D0/3.D0*z3*x + 248.D0*z3*dp + 80.D0/3.D0*z3*dm + & + & 3448.D0/9.D0*z2 + 2024.D0/9.D0*z2*x - 2144.D0/9.D0*z2*dp - 24.& + & D0/5.D0*z2**2 + 56.D0/5.D0*z2**2*x + 8.D0*z2**2*dp - 552.D0/5.& + & D0*z2**2*dm + 672.D0*Hr1(-1)*z3 - 672.D0*Hr1(-1)*z3*x - 1344.D& + & 0*Hr1(-1)*z3*dp - 992.D0/3.D0*Hr1(-1)*z2 - 1984.D0/3.D0*Hr1( & + & -1)*z2*x - 992.D0/3.D0*Hr1(-1)*z2*dp + 628.D0/9.D0*Hr1(0) + & + & 572.D0*Hr1(0)*x + 72.D0*Hr1(0)*dp - 302.D0/3.D0*Hr1(0)*dm - & + & 144.D0*Hr1(0)*z3 + 400.D0*Hr1(0)*z3*x + 464.D0*Hr1(0)*z3*dp & + & - 272.D0*Hr1(0)*z3*dm + 72.D0*Hr1(0)*z2 + 1208.D0/3.D0*Hr1(0 & + & )*z2*x + 104.D0/3.D0*Hr1(0)*z2*dp + 328.D0/3.D0*Hr1(0)*z2*dm & + & - 1672.D0/3.D0*Hr1(1) + 1672.D0/3.D0*Hr1(1)*x + 384.D0*Hr1(1 & + & )*z3 + 384.D0*Hr1(1)*z3*x - 768.D0*Hr1(1)*z3*dm - 112.D0*Hr1( & + & 1)*z2 + 112.D0*Hr1(1)*z2*x - 896.D0*Hr2(-1,-1)*z2 + 896.D0* & + & Hr2(-1,-1)*z2*x + 1792.D0*Hr2(-1,-1)*z2*dp + 1520.D0/9.D0* & + & Hr2(-1,0) ) + gqq2 = gqq2 + cf**2*ca * ( - 2768.D0/9.D0*Hr2(-1,0)*x - 4288.D0/ & + & 9.D0*Hr2(-1,0)*dp + 672.D0*Hr2(-1,0)*z2 - 672.D0*Hr2(-1,0)*z2 & + & *x - 1344.D0*Hr2(-1,0)*z2*dp + 576.D0*Hr2(0,-1)*z2 - 480.D0* & + & Hr2(0,-1)*z2*x - 1024.D0*Hr2(0,-1)*z2*dp - 96.D0*Hr2(0,-1)*z2 & + & *dm - 88.D0/3.D0*Hr2(0,0) - 2560.D0/9.D0*Hr2(0,0)*x + 2144.D0/& + & 9.D0*Hr2(0,0)*dp - 104.D0*Hr2(0,0)*dm - 96.D0*Hr2(0,0)*z2 + & + & 352.D0*Hr2(0,0)*z2*x + 416.D0*Hr2(0,0)*z2*dp - 128.D0*Hr2(0,0 & + & )*z2*dm - 3448.D0/9.D0*Hr2(0,1) - 4792.D0/9.D0*Hr2(0,1)*x + & + & 2144.D0/9.D0*Hr2(0,1)*dm + 160.D0*Hr2(0,1)*z2 - 64.D0*Hr2(0,1 & + & )*z2*x - 224.D0*Hr2(0,1)*z2*dp - 64.D0*Hr2(0,1)*z2*dm - 400.D0& + & /9.D0*Hr2(1,0) - 1744.D0/9.D0*Hr2(1,0)*x + 2144.D0/9.D0*Hr2(1 & + & ,0)*dm + 32.D0*Hr2(1,0)*z2 + 32.D0*Hr2(1,0)*z2*x - 64.D0*Hr2( & + & 1,0)*z2*dm - 224.D0*Hr3(-1,-1,0) - 224.D0*Hr3(-1,-1,0)*x + & + & 1352.D0/3.D0*Hr3(-1,0,0) + 856.D0/3.D0*Hr3(-1,0,0)*x - 496.D0/& + & 3.D0*Hr3(-1,0,0)*dp + 656.D0/3.D0*Hr3(-1,0,1) + 1648.D0/3.D0* & + & Hr3(-1,0,1)*x ) + gqq2 = gqq2 + cf**2*ca * ( 992.D0/3.D0*Hr3(-1,0,1)*dp + 368.D0/3.D& + & 0*Hr3(0,-1,0) + 208.D0/3.D0*Hr3(0,-1,0)*x - 496.D0/3.D0*Hr3(0 & + & ,-1,0)*dp + 96.D0*Hr3(0,-1,0)*dm - 132.D0*Hr3(0,0,0) - 476.D0/& + & 3.D0*Hr3(0,0,0)*x + 712.D0/3.D0*Hr3(0,0,0)*dp - 184.D0/3.D0* & + & Hr3(0,0,0)*dm - 72.D0*Hr3(0,0,1) - 1000.D0/3.D0*Hr3(0,0,1)*x & + & - 496.D0/3.D0*Hr3(0,0,1)*dp + 64.D0/3.D0*Hr3(0,0,1)*dm - 176.& + & D0/3.D0*Hr3(0,1,0) - 176.D0/3.D0*Hr3(0,1,0)*x + 352.D0/3.D0* & + & Hr3(0,1,0)*dm - 304.D0/3.D0*Hr3(1,0,0) - 688.D0/3.D0*Hr3(1,0, & + & 0)*x + 992.D0/3.D0*Hr3(1,0,0)*dm + 576.D0*Hr4(-1,-1,0,0) - & + & 576.D0*Hr4(-1,-1,0,0)*x - 1152.D0*Hr4(-1,-1,0,0)*dp + 896.D0* & + & Hr4(-1,-1,0,1) - 896.D0*Hr4(-1,-1,0,1)*x - 1792.D0*Hr4(-1,-1, & + & 0,1)*dp + 64.D0*Hr4(-1,0,-1,0) - 64.D0*Hr4(-1,0,-1,0)*x - 128.& + & D0*Hr4(-1,0,-1,0)*dp - 272.D0*Hr4(-1,0,0,0) + 272.D0*Hr4(-1,0 & + & ,0,0)*x + 544.D0*Hr4(-1,0,0,0)*dp - 512.D0*Hr4(-1,0,0,1) + & + & 512.D0*Hr4(-1,0,0,1)*x + 1024.D0*Hr4(-1,0,0,1)*dp - 32.D0* & + & Hr4(-1,0,1,0) ) + gqq2 = gqq2 + cf**2*ca * ( 32.D0*Hr4(-1,0,1,0)*x + 64.D0*Hr4(-1,0 & + & ,1,0)*dp + 320.D0*Hr4(0,-1,-1,0) + 128.D0*Hr4(0,-1,-1,0)*x - & + & 128.D0*Hr4(0,-1,-1,0)*dp - 448.D0*Hr4(0,-1,-1,0)*dm - 464.D0* & + & Hr4(0,-1,0,0) + 304.D0*Hr4(0,-1,0,0)*x + 672.D0*Hr4(0,-1,0,0) & + & *dp + 160.D0*Hr4(0,-1,0,0)*dm - 416.D0*Hr4(0,-1,0,1) + 544.D0 & + & *Hr4(0,-1,0,1)*x + 960.D0*Hr4(0,-1,0,1)*dp - 128.D0*Hr4(0,-1, & + & 0,1)*dm - 128.D0*Hr4(0,0,-1,0) + 128.D0*Hr4(0,0,-1,0)*x + 160.& + & D0*Hr4(0,0,-1,0)*dp - 32.D0*Hr4(0,0,-1,0)*dm - 224.D0*Hr4(0,0 & + & ,0,0)*x - 160.D0*Hr4(0,0,0,0)*dp + 160.D0*Hr4(0,0,0,0)*dm + & + & 96.D0*Hr4(0,0,0,1) - 224.D0*Hr4(0,0,0,1)*x - 320.D0*Hr4(0,0,0 & + & ,1)*dp + 32.D0*Hr4(0,0,0,1)*dm - 32.D0*Hr4(0,0,1,0)*x - 32.D0 & + & *Hr4(0,0,1,0)*dp + 32.D0*Hr4(0,0,1,0)*dm - 48.D0*Hr4(0,1,0,0) & + & - 48.D0*Hr4(0,1,0,0)*x + 160.D0*Hr4(0,1,0,0)*dm + 256.D0* & + & Hr4(1,0,-1,0) + 256.D0*Hr4(1,0,-1,0)*x - 512.D0*Hr4(1,0,-1,0) & + & *dm - 176.D0*Hr4(1,0,0,0) - 176.D0*Hr4(1,0,0,0)*x + 352.D0* & + & Hr4(1,0,0,0)*dm ) + gqq2 = gqq2 + cf**2*ca * ( 128.D0*Hr4(1,0,0,1) + 128.D0*Hr4(1,0,0 & + & ,1)*x - 256.D0*Hr4(1,0,0,1)*dm - 128.D0*Hr4(1,1,0,0) - 128.D0 & + & *Hr4(1,1,0,0)*x + 256.D0*Hr4(1,1,0,0)*dm ) + gqq2 = gqq2 + cf**3 * ( - 62.D0 + 62.D0*x - 48.D0*z3 - 720.D0*z3 & + & *x - 144.D0*z3*dp - 308.D0*z2 - 372.D0*z2*x - 56.D0/5.D0* & + & z2**2 + 504.D0/5.D0*z2**2*x + 112.D0*z2**2*dp + 144.D0/5.D0* & + & z2**2*dm - 576.D0*Hr1(-1)*z3 + 576.D0*Hr1(-1)*z3*x + 1152.D0* & + & Hr1(-1)*z3*dp + 384.D0*Hr1(-1)*z2 + 576.D0*Hr1(-1)*z2*x + 192.& + & D0*Hr1(-1)*z2*dp + 24.D0*Hr1(0) - 560.D0*Hr1(0)*x - 48.D0* & + & Hr1(0)*dp - 6.D0*Hr1(0)*dm + 288.D0*Hr1(0)*z3 - 224.D0*Hr1(0) & + & *z3*x - 416.D0*Hr1(0)*z3*dp + 32.D0*Hr1(0)*z3*dm - 96.D0*Hr1( & + & 0)*z2 - 448.D0*Hr1(0)*z2*x - 48.D0*Hr1(0)*z2*dp - 48.D0*Hr1(0 & + & )*z2*dm + 560.D0*Hr1(1) - 560.D0*Hr1(1)*x - 192.D0*Hr1(1)*z3 & + & - 192.D0*Hr1(1)*z3*x + 384.D0*Hr1(1)*z3*dm + 96.D0*Hr1(1)*z2 & + & - 96.D0*Hr1(1)*z2*x + 768.D0*Hr2(-1,-1)*z2 - 768.D0*Hr2(-1, & + & -1)*z2*x - 1536.D0*Hr2(-1,-1)*z2*dp - 32.D0*Hr2(-1,0) - 32.D0 & + & *Hr2(-1,0)*x - 640.D0*Hr2(-1,0)*z2 + 640.D0*Hr2(-1,0)*z2*x + & + & 1280.D0*Hr2(-1,0)*z2*dp - 608.D0*Hr2(0,-1)*z2 + 416.D0*Hr2(0, & + & -1)*z2*x ) + gqq2 = gqq2 + cf**3 * ( 1024.D0*Hr2(0,-1)*z2*dp + 192.D0*Hr2(0,-1 & + & )*z2*dm - 44.D0*Hr2(0,0) + 356.D0*Hr2(0,0)*x + 52.D0*Hr2(0,0) & + & *dm + 240.D0*Hr2(0,0)*z2 - 240.D0*Hr2(0,0)*z2*x - 448.D0*Hr2( & + & 0,0)*z2*dp + 308.D0*Hr2(0,1) + 340.D0*Hr2(0,1)*x - 96.D0*Hr2( & + & 0,1)*z2 + 96.D0*Hr2(0,1)*z2*x + 192.D0*Hr2(0,1)*z2*dp - 16.D0 & + & *Hr2(1,0) + 16.D0*Hr2(1,0)*x + 192.D0*Hr3(-1,-1,0) + 192.D0* & + & Hr3(-1,-1,0)*x - 464.D0*Hr3(-1,0,0) - 368.D0*Hr3(-1,0,0)*x + & + & 96.D0*Hr3(-1,0,0)*dp - 288.D0*Hr3(-1,0,1) - 480.D0*Hr3(-1,0,1 & + & )*x - 192.D0*Hr3(-1,0,1)*dp - 128.D0*Hr3(0,-1,0) - 192.D0* & + & Hr3(0,-1,0)*x + 96.D0*Hr3(0,-1,0)*dp + 120.D0*Hr3(0,0,0) + & + & 248.D0*Hr3(0,0,0)*x - 144.D0*Hr3(0,0,0)*dp + 96.D0*Hr3(0,0,1) & + & + 256.D0*Hr3(0,0,1)*x + 96.D0*Hr3(0,0,1)*dp + 72.D0*Hr3(0,1, & + & 0) + 8.D0*Hr3(0,1,0)*x - 96.D0*Hr3(0,1,0)*dm + 96.D0*Hr3(1,0, & + & 0) + 96.D0*Hr3(1,0,0)*x - 192.D0*Hr3(1,0,0)*dm - 640.D0*Hr4( & + & -1,-1,0,0) + 640.D0*Hr4(-1,-1,0,0)*x + 1280.D0*Hr4(-1,-1,0,0) & + & *dp ) + gqq2 = gqq2 + cf**3 * ( - 768.D0*Hr4(-1,-1,0,1) + 768.D0*Hr4(-1, & + & -1,0,1)*x + 1536.D0*Hr4(-1,-1,0,1)*dp - 128.D0*Hr4(-1,0,-1,0) & + & + 128.D0*Hr4(-1,0,-1,0)*x + 256.D0*Hr4(-1,0,-1,0)*dp + 352.D0& + & *Hr4(-1,0,0,0) - 352.D0*Hr4(-1,0,0,0)*x - 704.D0*Hr4(-1,0,0,0 & + & )*dp + 512.D0*Hr4(-1,0,0,1) - 512.D0*Hr4(-1,0,0,1)*x - 1024.D0& + & *Hr4(-1,0,0,1)*dp + 64.D0*Hr4(-1,0,1,0) - 64.D0*Hr4(-1,0,1,0) & + & *x - 128.D0*Hr4(-1,0,1,0)*dp - 320.D0*Hr4(0,-1,-1,0) - 64.D0* & + & Hr4(0,-1,-1,0)*x + 256.D0*Hr4(0,-1,-1,0)*dp + 384.D0*Hr4(0,-1 & + & ,-1,0)*dm + 576.D0*Hr4(0,-1,0,0) - 384.D0*Hr4(0,-1,0,0)*x - & + & 832.D0*Hr4(0,-1,0,0)*dp - 192.D0*Hr4(0,-1,0,0)*dm + 448.D0* & + & Hr4(0,-1,0,1) - 448.D0*Hr4(0,-1,0,1)*x - 896.D0*Hr4(0,-1,0,1) & + & *dp + 224.D0*Hr4(0,0,-1,0) - 96.D0*Hr4(0,0,-1,0)*x - 192.D0* & + & Hr4(0,0,-1,0)*dp - 64.D0*Hr4(0,0,-1,0)*dm - 112.D0*Hr4(0,0,0, & + & 0) + 176.D0*Hr4(0,0,0,0)*x + 192.D0*Hr4(0,0,0,0)*dp - 64.D0* & + & Hr4(0,0,0,0)*dm - 240.D0*Hr4(0,0,0,1) + 144.D0*Hr4(0,0,0,1)*x & + & + 384.D0*Hr4(0,0,0,1)*dp ) + gqq2 = gqq2 + cf**3 * ( 64.D0*Hr4(0,0,0,1)*dm - 128.D0*Hr4(0,0,1, & + & 0) - 64.D0*Hr4(0,0,1,0)*x + 64.D0*Hr4(0,0,1,0)*dp + 128.D0* & + & Hr4(0,0,1,0)*dm - 64.D0*Hr4(0,0,1,1) - 64.D0*Hr4(0,0,1,1)*x & + & + 128.D0*Hr4(0,0,1,1)*dm - 80.D0*Hr4(0,1,0,0) - 80.D0*Hr4(0, & + & 1,0,0)*x + 64.D0*Hr4(0,1,0,0)*dm - 64.D0*Hr4(0,1,0,1) - 64.D0 & + & *Hr4(0,1,0,1)*x + 128.D0*Hr4(0,1,0,1)*dm - 64.D0*Hr4(0,1,1,0) & + & - 64.D0*Hr4(0,1,1,0)*x + 128.D0*Hr4(0,1,1,0)*dm - 128.D0* & + & Hr4(1,0,-1,0) - 128.D0*Hr4(1,0,-1,0)*x + 256.D0*Hr4(1,0,-1,0) & + & *dm + 64.D0*Hr4(1,0,0,0) + 64.D0*Hr4(1,0,0,0)*x - 128.D0*Hr4( & + & 1,0,0,0)*dm - 128.D0*Hr4(1,0,0,1) - 128.D0*Hr4(1,0,0,1)*x + & + & 256.D0*Hr4(1,0,0,1)*dm - 64.D0*Hr4(1,0,1,0) - 64.D0*Hr4(1,0,1 & + & ,0)*x + 128.D0*Hr4(1,0,1,0)*dm ) +! + gqq2 = gqq2 & + & + nf*cf*ca * ( - 182.D0/3.D0 + 160.D0/9.D0*z2*dm - 160.D0/9.D0 & + & *z2*dp - 184.D0/9.D0*z2*x + 8.D0*z2 - 48.D0*z3*dm + 16.D0*z3* & + & dp + 32.D0*z3*x + 16.D0*z3 - 836.D0/27.D0*dm + 2474.D0/27.D0* & + & x - 64.D0/3.D0*Hr1(-1)*z2*dp - 32.D0/3.D0*Hr1(-1)*z2*x + 32.D0& + & /3.D0*Hr1(-1)*z2 + 68.D0/27.D0*Hr1(0) + 32.D0/3.D0*Hr1(0)*z2* & + & dm + 16.D0/3.D0*Hr1(0)*z2*dp - 8.D0/3.D0*Hr1(0)*z2*x - 8.D0* & + & Hr1(0)*z2 - 1336.D0/27.D0*Hr1(0)*dm + 1700.D0/27.D0*Hr1(0)*x & + & - 16.D0*Hr1(1) + 16.D0*Hr1(1)*x + 64.D0/9.D0*Hr2(-1,0) - 320.& + & D0/9.D0*Hr2(-1,0)*dp - 256.D0/9.D0*Hr2(-1,0)*x + 88.D0/9.D0* & + & Hr2(0,0) - 112.D0/3.D0*Hr2(0,0)*dm + 160.D0/9.D0*Hr2(0,0)*dp & + & + 272.D0/9.D0*Hr2(0,0)*x - 8.D0*Hr2(0,1) - 8.D0*Hr2(0,1)*x & + & + 16.D0/3.D0*Hr3(-1,0,0) - 32.D0/3.D0*Hr3(-1,0,0)*dp - 16.D0/& + & 3.D0*Hr3(-1,0,0)*x - 32.D0/3.D0*Hr3(-1,0,1) + 64.D0/3.D0*Hr3( & + & -1,0,1)*dp + 32.D0/3.D0*Hr3(-1,0,1)*x + 16.D0/3.D0*Hr3(0,-1,0 & + & ) - 32.D0/3.D0*Hr3(0,-1,0)*dp - 16.D0/3.D0*Hr3(0,-1,0)*x - 32.& + & D0/3.D0*Hr3(0,0,0)*dm ) + gqq2 = gqq2 + nf*cf*ca * ( 32.D0/3.D0*Hr3(0,0,0)*dp + 32.D0/3.D0* & + & Hr3(0,0,0)*x + 8.D0*Hr3(0,0,1) - 16.D0/3.D0*Hr3(0,0,1)*dm - & + & 32.D0/3.D0*Hr3(0,0,1)*dp - 8.D0/3.D0*Hr3(0,0,1)*x - 8.D0*Hr3( & + & 1,0,0) + 16.D0*Hr3(1,0,0)*dm - 8.D0*Hr3(1,0,0)*x ) + gqq2 = gqq2 + nf*cf**2 * ( 5.D0/9.D0 + 320.D0/9.D0*z2*dp + 160.D0/& + & 9.D0*z2*x - 160.D0/9.D0*z2 + 160.D0/3.D0*z3*dm - 32.D0*z3*dp & + & - 128.D0/3.D0*z3*x - 32.D0/3.D0*z3 - 110.D0/3.D0*dm + 325.D0/& + & 9.D0*x + 128.D0/3.D0*Hr1(-1)*z2*dp + 64.D0/3.D0*Hr1(-1)*z2*x & + & - 64.D0/3.D0*Hr1(-1)*z2 - 148.D0/9.D0*Hr1(0) + 32.D0/3.D0* & + & Hr1(0)*z2*dm - 32.D0/3.D0*Hr1(0)*z2*dp - 32.D0/3.D0*Hr1(0)*z2 & + & *x + 20.D0/3.D0*Hr1(0)*dm - 20.D0*Hr1(0)*x + 64.D0/3.D0*Hr1(1 & + & ) - 64.D0/3.D0*Hr1(1)*x - 128.D0/9.D0*Hr2(-1,0) + 640.D0/9.D0 & + & *Hr2(-1,0)*dp + 512.D0/9.D0*Hr2(-1,0)*x + 16.D0/3.D0*Hr2(0,0) & + & + 16.D0*Hr2(0,0)*dm - 320.D0/9.D0*Hr2(0,0)*dp - 80.D0/9.D0* & + & Hr2(0,0)*x + 160.D0/9.D0*Hr2(0,1) - 320.D0/9.D0*Hr2(0,1)*dm & + & + 352.D0/9.D0*Hr2(0,1)*x + 64.D0/9.D0*Hr2(1,0) - 320.D0/9.D0 & + & *Hr2(1,0)*dm + 256.D0/9.D0*Hr2(1,0)*x - 32.D0/3.D0*Hr3(-1,0,0 & + & ) + 64.D0/3.D0*Hr3(-1,0,0)*dp + 32.D0/3.D0*Hr3(-1,0,0)*x + 64.& + & D0/3.D0*Hr3(-1,0,1) - 128.D0/3.D0*Hr3(-1,0,1)*dp - 64.D0/3.D0 & + & *Hr3(-1,0,1)*x ) + gqq2 = gqq2 + nf*cf**2 * ( - 32.D0/3.D0*Hr3(0,-1,0) + 64.D0/3.D0 & + & *Hr3(0,-1,0)*dp + 32.D0/3.D0*Hr3(0,-1,0)*x + 24.D0*Hr3(0,0,0) & + & - 32.D0/3.D0*Hr3(0,0,0)*dm - 64.D0/3.D0*Hr3(0,0,0)*dp + 8.D0/& + & 3.D0*Hr3(0,0,0)*x - 64.D0/3.D0*Hr3(0,0,1)*dm + 64.D0/3.D0* & + & Hr3(0,0,1)*dp + 64.D0/3.D0*Hr3(0,0,1)*x + 32.D0/3.D0*Hr3(0,1, & + & 0) - 64.D0/3.D0*Hr3(0,1,0)*dm + 32.D0/3.D0*Hr3(0,1,0)*x + 64.D& + & 0/3.D0*Hr3(1,0,0) - 128.D0/3.D0*Hr3(1,0,0)*dm + 64.D0/3.D0* & + & Hr3(1,0,0)*x ) + gqq2 = gqq2 + nf2*cf * ( 112.D0/27.D0 - 16.D0/27.D0*dm - 32.D0/ & + & 9.D0*x + 8.D0/27.D0*Hr1(0) + 80.D0/27.D0*Hr1(0)*dm - 88.D0/27.& + & D0*Hr1(0)*x - 8.D0/9.D0*Hr2(0,0) + 16.D0/9.D0*Hr2(0,0)*dm - 8.& + & D0/9.D0*Hr2(0,0)*x ) +! +! ...The soft (`+'-distribution) part of the splitting function +! + ! GPS: now included from module qcd +! A3 = & +! & ca**2*cf * ( + 490.D0/3.D0 + 88.D0/3.D0*z3 - 1072.D0/9.D0*z2& +! & + 176.D0/5.D0*z2**2 ) & +! & + ca*cf*nf * ( - 836./27.D0 + 160./9.D0*z2 - 112./3.D0*z3 ) & +! & + cf**2*nf * ( - 110./3.D0 + 32.*z3 ) - cf*nf2 * 16./27.D0 +! + GQQ2L = DM * A3 +! +! ...The regular piece of the splitting function +! + X2NSPA = GQQ2 - GQQ2L +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the regular piece of P_NS- +! + FUNCTION X2NSMA (X, NF) +! + IMPLICIT REAL*8 (A - Z) + COMPLEX*16 HC1, HC2, HC3, HC4 + INTEGER NF, NF2, N1, N2, NW, I1, I2, I3, N + PARAMETER ( N1 = -1, N2 = 1, NW = 4 ) + DIMENSION HC1(N1:N2),HC2(N1:N2,N1:N2),HC3(N1:N2,N1:N2,N1:N2), & + & HC4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HR1(N1:N2),HR2(N1:N2,N1:N2),HR3(N1:N2,N1:N2,N1:N2), & + & HR4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HI1(N1:N2),HI2(N1:N2,N1:N2),HI3(N1:N2,N1:N2,N1:N2), & + & HI4(N1:N2,N1:N2,N1:N2,N1:N2) + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0, & + & Z5 = 1.0369 27755 14336 99263 D0 ) +! +! ..The soft coefficient for use in X2NSPB and X2NSPC +! +! COMMON / P2SOFT / A3 +! +! ...Colour factors +! + !CF = 4./3.D0 + !CA = 3.D0 + NF2 = NF*NF +! +! ...Some abbreviations +! + DX = 1.D0/X + DM = 1.D0/(1.D0-X) + DP = 1.D0/(1.D0+X) +! +! ...The harmonic polylogs up to weight 4 by Gehrmann and Remiddi +! + CALL HPLOG (X, NW, HC1,HC2,HC3,HC4, HR1,HR2,HR3,HR4, & + & HI1,HI2,HI3,HI4, N1, N2) +! +! ...The splitting function in terms of the harmonic polylogs +! (without the delta(1-x) part, but with the soft contribution) +! + gqq2 = cf*ca**2 * ( 923.D0/27.D0 - 5333.D0/27.D0*x + 490.D0 & + & /3.D0*dm + 112.D0*z3 + 48.D0*z3*x + 88.D0*z3*dp + 16.D0*z3*dm & + & + 1504.D0/9.D0*z2 + 224.D0/3.D0*z2*x - 1072.D0/9.D0*z2*dp - & + & 1072.D0/9.D0*z2*dm - 242.D0/5.D0*z2**2 - 62.D0/5.D0*z2**2*x & + & + 32.D0*z2**2*dp + 384.D0/5.D0*z2**2*dm + 192.D0*Hr1(-1)*z3 & + & - 192.D0*Hr1(-1)*z3*x - 384.D0*Hr1(-1)*z3*dp - 208.D0/3.D0* & + & Hr1(-1)*z2 - 560.D0/3.D0*Hr1(-1)*z2*x - 352.D0/3.D0*Hr1(-1)* & + & z2*dp - 1378.D0/27.D0*Hr1(0) - 2266.D0/27.D0*Hr1(0)*x + 24.D0 & + & *Hr1(0)*dp + 4172.D0/27.D0*Hr1(0)*dm - 144.D0*Hr1(0)*z3 + 128.& + & D0*Hr1(0)*z3*dp + 128.D0*Hr1(0)*z3*dm + 332.D0/3.D0*Hr1(0)*z2 & + & + 188.D0*Hr1(0)*z2*x + 16.D0/3.D0*Hr1(0)*z2*dp - 248.D0/3.D0 & + & *Hr1(0)*z2*dm - 592.D0/3.D0*Hr1(1) + 592.D0/3.D0*Hr1(1)*x - & + & 144.D0*Hr1(1)*z3 - 144.D0*Hr1(1)*z3*x + 288.D0*Hr1(1)*z3*dm & + & - 32.D0*Hr1(1)*z2 + 32.D0*Hr1(1)*z2*x - 256.D0*Hr2(-1,-1)*z2 & + & + 256.D0*Hr2(-1,-1)*z2*x + 512.D0*Hr2(-1,-1)*z2*dp + 832.D0/ & + & 9.D0*Hr2(-1,0) ) + gqq2 = gqq2 + cf*ca**2 * ( - 1312.D0/9.D0*Hr2(-1,0)*x - 2144.D0/ & + & 9.D0*Hr2(-1,0)*dp + 176.D0*Hr2(-1,0)*z2 - 176.D0*Hr2(-1,0)*z2 & + & *x - 352.D0*Hr2(-1,0)*z2*dp + 136.D0*Hr2(0,-1)*z2 - 136.D0* & + & Hr2(0,-1)*z2*x - 256.D0*Hr2(0,-1)*z2*dp - 130.D0*Hr2(0,0) + & + & 238.D0/9.D0*Hr2(0,0)*x + 1072.D0/9.D0*Hr2(0,0)*dp + 1556.D0/9.& + & D0*Hr2(0,0)*dm - 68.D0*Hr2(0,0)*z2 + 36.D0*Hr2(0,0)*z2*x + 96.& + & D0*Hr2(0,0)*z2*dp - 224.D0/3.D0*Hr2(0,1) - 224.D0/3.D0*Hr2(0, & + & 1)*x + 24.D0*Hr2(0,1)*z2 - 40.D0*Hr2(0,1)*z2*x - 64.D0*Hr2(0, & + & 1)*z2*dp + 16.D0*Hr2(1,0)*z2 + 16.D0*Hr2(1,0)*z2*x - 32.D0* & + & Hr2(1,0)*z2*dm + 64.D0*Hr3(-1,-1,0) + 64.D0*Hr3(-1,-1,0)*x + & + & 232.D0/3.D0*Hr3(-1,0,0) + 56.D0/3.D0*Hr3(-1,0,0)*x - 176.D0/3.& + & D0*Hr3(-1,0,0)*dp + 304.D0/3.D0*Hr3(-1,0,1) + 656.D0/3.D0* & + & Hr3(-1,0,1)*x + 352.D0/3.D0*Hr3(-1,0,1)*dp + 328.D0/3.D0*Hr3( & + & 0,-1,0) - 376.D0/3.D0*Hr3(0,-1,0)*x - 176.D0/3.D0*Hr3(0,-1,0) & + & *dp - 48.D0*Hr3(0,-1,0)*dm - 416.D0/3.D0*Hr3(0,0,0) + 248.D0/ & + & 3.D0*Hr3(0,0,0)*dp ) + gqq2 = gqq2 + cf*ca**2 * ( 248.D0/3.D0*Hr3(0,0,0)*dm - 4.D0/3.D0* & + & Hr3(0,0,1) - 188.D0*Hr3(0,0,1)*x - 176.D0/3.D0*Hr3(0,0,1)*dp & + & + 88.D0/3.D0*Hr3(0,0,1)*dm + 12.D0*Hr3(1,0,0) + 76.D0*Hr3(1, & + & 0,0)*x - 88.D0*Hr3(1,0,0)*dm + 128.D0*Hr4(-1,-1,0,0) - 128.D0 & + & *Hr4(-1,-1,0,0)*x - 256.D0*Hr4(-1,-1,0,0)*dp + 256.D0*Hr4(-1, & + & -1,0,1) - 256.D0*Hr4(-1,-1,0,1)*x - 512.D0*Hr4(-1,-1,0,1)*dp & + & - 48.D0*Hr4(-1,0,0,0) + 48.D0*Hr4(-1,0,0,0)*x + 96.D0*Hr4(-1 & + & ,0,0,0)*dp - 128.D0*Hr4(-1,0,0,1) + 128.D0*Hr4(-1,0,0,1)*x + & + & 256.D0*Hr4(-1,0,0,1)*dp - 48.D0*Hr4(0,-1,-1,0) - 80.D0*Hr4(0, & + & -1,-1,0)*x + 128.D0*Hr4(0,-1,-1,0)*dm - 56.D0*Hr4(0,-1,0,0) & + & + 88.D0*Hr4(0,-1,0,0)*x + 128.D0*Hr4(0,-1,0,0)*dp - 32.D0* & + & Hr4(0,-1,0,0)*dm - 160.D0*Hr4(0,-1,0,1) + 96.D0*Hr4(0,-1,0,1) & + & *x + 256.D0*Hr4(0,-1,0,1)*dp + 64.D0*Hr4(0,-1,0,1)*dm - 40.D0 & + & *Hr4(0,0,-1,0) + 8.D0*Hr4(0,0,-1,0)*x + 32.D0*Hr4(0,0,-1,0)* & + & dp + 32.D0*Hr4(0,0,-1,0)*dm + 40.D0*Hr4(0,0,0,0) - 32.D0*Hr4( & + & 0,0,0,0)*dp ) + gqq2 = gqq2 + cf*ca**2 * ( - 32.D0*Hr4(0,0,0,0)*dm + 28.D0*Hr4(0 & + & ,0,0,1) - 36.D0*Hr4(0,0,0,1)*x - 64.D0*Hr4(0,0,0,1)*dp + 32.D0& + & *Hr4(0,0,0,1)*dm + 28.D0*Hr4(0,1,0,0) + 28.D0*Hr4(0,1,0,0)*x & + & - 64.D0*Hr4(0,1,0,0)*dm - 96.D0*Hr4(1,0,-1,0) - 96.D0*Hr4(1, & + & 0,-1,0)*x + 192.D0*Hr4(1,0,-1,0)*dm + 48.D0*Hr4(1,0,0,0) + 48.& + & D0*Hr4(1,0,0,0)*x - 96.D0*Hr4(1,0,0,0)*dm - 64.D0*Hr4(1,0,0,1 & + & ) - 64.D0*Hr4(1,0,0,1)*x + 128.D0*Hr4(1,0,0,1)*dm + 64.D0* & + & Hr4(1,1,0,0) + 64.D0*Hr4(1,1,0,0)*x - 128.D0*Hr4(1,1,0,0)*dm & + & ) + gqq2 = gqq2 + cf**2*ca * ( 1516.D0/3.D0 - 1516.D0/3.D0*x - 832.D0/& + & 3.D0*z3 - 880.D0/3.D0*z3*x - 248.D0*z3*dp + 80.D0/3.D0*z3*dm & + & - 3880.D0/9.D0*z2 - 152.D0/9.D0*z2*x + 2144.D0/9.D0*z2*dp + & + & 56.D0/5.D0*z2**2 - 24.D0/5.D0*z2**2*x - 8.D0*z2**2*dp - 552.D0& + & /5.D0*z2**2*dm - 672.D0*Hr1(-1)*z3 + 672.D0*Hr1(-1)*z3*x + & + & 1344.D0*Hr1(-1)*z3*dp + 704.D0/3.D0*Hr1(-1)*z2 + 1696.D0/3.D0 & + & *Hr1(-1)*z2*x + 992.D0/3.D0*Hr1(-1)*z2*dp + 3404.D0/9.D0*Hr1( & + & 0) - 3740.D0/9.D0*Hr1(0)*x - 72.D0*Hr1(0)*dp - 302.D0/3.D0* & + & Hr1(0)*dm + 400.D0*Hr1(0)*z3 - 144.D0*Hr1(0)*z3*x - 464.D0* & + & Hr1(0)*z3*dp - 272.D0*Hr1(0)*z3*dm - 904.D0/3.D0*Hr1(0)*z2 - & + & 568.D0*Hr1(0)*z2*x - 104.D0/3.D0*Hr1(0)*z2*dp + 328.D0/3.D0* & + & Hr1(0)*z2*dm + 2008.D0/3.D0*Hr1(1) - 2008.D0/3.D0*Hr1(1)*x + & + & 384.D0*Hr1(1)*z3 + 384.D0*Hr1(1)*z3*x - 768.D0*Hr1(1)*z3*dm & + & + 112.D0*Hr1(1)*z2 - 112.D0*Hr1(1)*z2*x + 896.D0*Hr2(-1,-1)* & + & z2 - 896.D0*Hr2(-1,-1)*z2*x - 1792.D0*Hr2(-1,-1)*z2*dp - 1232.& + & D0/9.D0*Hr2(-1,0) ) + gqq2 = gqq2 + cf**2*ca * ( 3056.D0/9.D0*Hr2(-1,0)*x + 4288.D0/9.D0& + & *Hr2(-1,0)*dp - 672.D0*Hr2(-1,0)*z2 + 672.D0*Hr2(-1,0)*z2*x & + & + 1344.D0*Hr2(-1,0)*z2*dp - 480.D0*Hr2(0,-1)*z2 + 576.D0* & + & Hr2(0,-1)*z2*x + 1024.D0*Hr2(0,-1)*z2*dp - 96.D0*Hr2(0,-1)*z2 & + & *dm + 2168.D0/9.D0*Hr2(0,0) - 944.D0/3.D0*Hr2(0,0)*x - 2144.D0& + & /9.D0*Hr2(0,0)*dp - 104.D0*Hr2(0,0)*dm + 352.D0*Hr2(0,0)*z2 & + & - 96.D0*Hr2(0,0)*z2*x - 416.D0*Hr2(0,0)*z2*dp - 128.D0*Hr2(0 & + & ,0)*z2*dm + 2648.D0/9.D0*Hr2(0,1) + 152.D0/9.D0*Hr2(0,1)*x + & + & 2144.D0/9.D0*Hr2(0,1)*dm - 64.D0*Hr2(0,1)*z2 + 160.D0*Hr2(0,1 & + & )*z2*x + 224.D0*Hr2(0,1)*z2*dp - 64.D0*Hr2(0,1)*z2*dm + 176.D0& + & /9.D0*Hr2(1,0) - 2320.D0/9.D0*Hr2(1,0)*x + 2144.D0/9.D0*Hr2(1 & + & ,0)*dm + 32.D0*Hr2(1,0)*z2 + 32.D0*Hr2(1,0)*z2*x - 64.D0*Hr2( & + & 1,0)*z2*dm - 224.D0*Hr3(-1,-1,0) - 224.D0*Hr3(-1,-1,0)*x - & + & 872.D0/3.D0*Hr3(-1,0,0) - 376.D0/3.D0*Hr3(-1,0,0)*x + 496.D0/ & + & 3.D0*Hr3(-1,0,0)*dp - 1040.D0/3.D0*Hr3(-1,0,1) - 2032.D0/3.D0 & + & *Hr3(-1,0,1)*x ) + gqq2 = gqq2 + cf**2*ca * ( - 992.D0/3.D0*Hr3(-1,0,1)*dp - 752.D0/& + & 3.D0*Hr3(0,-1,0) + 944.D0/3.D0*Hr3(0,-1,0)*x + 496.D0/3.D0* & + & Hr3(0,-1,0)*dp + 96.D0*Hr3(0,-1,0)*dm + 868.D0/3.D0*Hr3(0,0,0 & + & ) - 36.D0*Hr3(0,0,0)*x - 712.D0/3.D0*Hr3(0,0,0)*dp - 184.D0/3.& + & D0*Hr3(0,0,0)*dm + 152.D0/3.D0*Hr3(0,0,1) + 568.D0*Hr3(0,0,1) & + & *x + 496.D0/3.D0*Hr3(0,0,1)*dp + 64.D0/3.D0*Hr3(0,0,1)*dm - & + & 80.D0/3.D0*Hr3(0,1,0) - 80.D0/3.D0*Hr3(0,1,0)*x + 352.D0/3.D0 & + & *Hr3(0,1,0)*dm - 304.D0/3.D0*Hr3(1,0,0) - 688.D0/3.D0*Hr3(1,0 & + & ,0)*x + 992.D0/3.D0*Hr3(1,0,0)*dm - 576.D0*Hr4(-1,-1,0,0) + & + & 576.D0*Hr4(-1,-1,0,0)*x + 1152.D0*Hr4(-1,-1,0,0)*dp - 896.D0* & + & Hr4(-1,-1,0,1) + 896.D0*Hr4(-1,-1,0,1)*x + 1792.D0*Hr4(-1,-1, & + & 0,1)*dp - 64.D0*Hr4(-1,0,-1,0) + 64.D0*Hr4(-1,0,-1,0)*x + 128.& + & D0*Hr4(-1,0,-1,0)*dp + 272.D0*Hr4(-1,0,0,0) - 272.D0*Hr4(-1,0 & + & ,0,0)*x - 544.D0*Hr4(-1,0,0,0)*dp + 512.D0*Hr4(-1,0,0,1) - & + & 512.D0*Hr4(-1,0,0,1)*x - 1024.D0*Hr4(-1,0,0,1)*dp + 32.D0* & + & Hr4(-1,0,1,0) ) + gqq2 = gqq2 + cf**2*ca * ( - 32.D0*Hr4(-1,0,1,0)*x - 64.D0*Hr4( & + & -1,0,1,0)*dp + 128.D0*Hr4(0,-1,-1,0) + 320.D0*Hr4(0,-1,-1,0)* & + & x + 128.D0*Hr4(0,-1,-1,0)*dp - 448.D0*Hr4(0,-1,-1,0)*dm + 304.& + & D0*Hr4(0,-1,0,0) - 464.D0*Hr4(0,-1,0,0)*x - 672.D0*Hr4(0,-1,0 & + & ,0)*dp + 160.D0*Hr4(0,-1,0,0)*dm + 544.D0*Hr4(0,-1,0,1) - 416.& + & D0*Hr4(0,-1,0,1)*x - 960.D0*Hr4(0,-1,0,1)*dp - 128.D0*Hr4(0, & + & -1,0,1)*dm + 128.D0*Hr4(0,0,-1,0) - 128.D0*Hr4(0,0,-1,0)*x - & + & 160.D0*Hr4(0,0,-1,0)*dp - 32.D0*Hr4(0,0,-1,0)*dm - 224.D0* & + & Hr4(0,0,0,0) + 160.D0*Hr4(0,0,0,0)*dp + 160.D0*Hr4(0,0,0,0)* & + & dm - 224.D0*Hr4(0,0,0,1) + 96.D0*Hr4(0,0,0,1)*x + 320.D0*Hr4( & + & 0,0,0,1)*dp + 32.D0*Hr4(0,0,0,1)*dm - 32.D0*Hr4(0,0,1,0) + 32.& + & D0*Hr4(0,0,1,0)*dp + 32.D0*Hr4(0,0,1,0)*dm - 48.D0*Hr4(0,1,0, & + & 0) - 48.D0*Hr4(0,1,0,0)*x + 160.D0*Hr4(0,1,0,0)*dm + 256.D0* & + & Hr4(1,0,-1,0) + 256.D0*Hr4(1,0,-1,0)*x - 512.D0*Hr4(1,0,-1,0) & + & *dm - 176.D0*Hr4(1,0,0,0) - 176.D0*Hr4(1,0,0,0)*x + 352.D0* & + & Hr4(1,0,0,0)*dm ) + gqq2 = gqq2 + cf**2*ca * ( 128.D0*Hr4(1,0,0,1) + 128.D0*Hr4(1,0,0 & + & ,1)*x - 256.D0*Hr4(1,0,0,1)*dm - 128.D0*Hr4(1,1,0,0) - 128.D0 & + & *Hr4(1,1,0,0)*x + 256.D0*Hr4(1,1,0,0)*dm ) + gqq2 = gqq2 + cf**3 * ( - 302.D0 + 302.D0*x + 48.D0*z3 + 336.D0* & + & z3*x + 144.D0*z3*dp + 204.D0*z2 + 12.D0*z2*x + 504.D0/5.D0* & + & z2**2 - 56.D0/5.D0*z2**2*x - 112.D0*z2**2*dp + 144.D0/5.D0* & + & z2**2*dm + 576.D0*Hr1(-1)*z3 - 576.D0*Hr1(-1)*z3*x - 1152.D0* & + & Hr1(-1)*z3*dp - 192.D0*Hr1(-1)*z2 - 384.D0*Hr1(-1)*z2*x - 192.& + & D0*Hr1(-1)*z2*dp - 328.D0*Hr1(0) + 464.D0*Hr1(0)*x + 48.D0* & + & Hr1(0)*dp - 6.D0*Hr1(0)*dm - 224.D0*Hr1(0)*z3 + 288.D0*Hr1(0) & + & *z3*x + 416.D0*Hr1(0)*z3*dp + 32.D0*Hr1(0)*z3*dm + 192.D0* & + & Hr1(0)*z2 + 544.D0*Hr1(0)*z2*x + 48.D0*Hr1(0)*z2*dp - 48.D0* & + & Hr1(0)*z2*dm - 400.D0*Hr1(1) + 400.D0*Hr1(1)*x - 192.D0*Hr1(1 & + & )*z3 - 192.D0*Hr1(1)*z3*x + 384.D0*Hr1(1)*z3*dm - 96.D0*Hr1(1 & + & )*z2 + 96.D0*Hr1(1)*z2*x - 768.D0*Hr2(-1,-1)*z2 + 768.D0*Hr2( & + & -1,-1)*z2*x + 1536.D0*Hr2(-1,-1)*z2*dp - 96.D0*Hr2(-1,0) - 96.& + & D0*Hr2(-1,0)*x + 640.D0*Hr2(-1,0)*z2 - 640.D0*Hr2(-1,0)*z2*x & + & - 1280.D0*Hr2(-1,0)*z2*dp + 416.D0*Hr2(0,-1)*z2 - 608.D0* & + & Hr2(0,-1)*z2*x ) + gqq2 = gqq2 + cf**3 * ( - 1024.D0*Hr2(0,-1)*z2*dp + 192.D0*Hr2(0 & + & ,-1)*z2*dm - 172.D0*Hr2(0,0) + 4.D0*Hr2(0,0)*x + 52.D0*Hr2(0, & + & 0)*dm - 240.D0*Hr2(0,0)*z2 + 240.D0*Hr2(0,0)*z2*x + 448.D0* & + & Hr2(0,0)*z2*dp - 300.D0*Hr2(0,1) - 12.D0*Hr2(0,1)*x + 96.D0* & + & Hr2(0,1)*z2 - 96.D0*Hr2(0,1)*z2*x - 192.D0*Hr2(0,1)*z2*dp - & + & 144.D0*Hr2(1,0) + 144.D0*Hr2(1,0)*x + 192.D0*Hr3(-1,-1,0) + & + & 192.D0*Hr3(-1,-1,0)*x + 272.D0*Hr3(-1,0,0) + 176.D0*Hr3(-1,0, & + & 0)*x - 96.D0*Hr3(-1,0,0)*dp + 288.D0*Hr3(-1,0,1) + 480.D0* & + & Hr3(-1,0,1)*x + 192.D0*Hr3(-1,0,1)*dp + 64.D0*Hr3(0,-1,0) - & + & 128.D0*Hr3(0,-1,0)*x - 96.D0*Hr3(0,-1,0)*dp - 168.D0*Hr3(0,0, & + & 0) - 168.D0*Hr3(0,0,0)*x + 144.D0*Hr3(0,0,0)*dp - 128.D0*Hr3( & + & 0,0,1) - 544.D0*Hr3(0,0,1)*x - 96.D0*Hr3(0,0,1)*dp + 8.D0* & + & Hr3(0,1,0) - 56.D0*Hr3(0,1,0)*x - 96.D0*Hr3(0,1,0)*dm + 96.D0 & + & *Hr3(1,0,0) + 96.D0*Hr3(1,0,0)*x - 192.D0*Hr3(1,0,0)*dm + 640.& + & D0*Hr4(-1,-1,0,0) - 640.D0*Hr4(-1,-1,0,0)*x - 1280.D0*Hr4(-1, & + & -1,0,0)*dp ) + gqq2 = gqq2 + cf**3 * ( 768.D0*Hr4(-1,-1,0,1) - 768.D0*Hr4(-1,-1, & + & 0,1)*x - 1536.D0*Hr4(-1,-1,0,1)*dp + 128.D0*Hr4(-1,0,-1,0) - & + & 128.D0*Hr4(-1,0,-1,0)*x - 256.D0*Hr4(-1,0,-1,0)*dp - 352.D0* & + & Hr4(-1,0,0,0) + 352.D0*Hr4(-1,0,0,0)*x + 704.D0*Hr4(-1,0,0,0) & + & *dp - 512.D0*Hr4(-1,0,0,1) + 512.D0*Hr4(-1,0,0,1)*x + 1024.D0 & + & *Hr4(-1,0,0,1)*dp - 64.D0*Hr4(-1,0,1,0) + 64.D0*Hr4(-1,0,1,0) & + & *x + 128.D0*Hr4(-1,0,1,0)*dp - 64.D0*Hr4(0,-1,-1,0) - 320.D0* & + & Hr4(0,-1,-1,0)*x - 256.D0*Hr4(0,-1,-1,0)*dp + 384.D0*Hr4(0,-1 & + & ,-1,0)*dm - 384.D0*Hr4(0,-1,0,0) + 576.D0*Hr4(0,-1,0,0)*x + & + & 832.D0*Hr4(0,-1,0,0)*dp - 192.D0*Hr4(0,-1,0,0)*dm - 448.D0* & + & Hr4(0,-1,0,1) + 448.D0*Hr4(0,-1,0,1)*x + 896.D0*Hr4(0,-1,0,1) & + & *dp - 96.D0*Hr4(0,0,-1,0) + 224.D0*Hr4(0,0,-1,0)*x + 192.D0* & + & Hr4(0,0,-1,0)*dp - 64.D0*Hr4(0,0,-1,0)*dm + 176.D0*Hr4(0,0,0, & + & 0) - 112.D0*Hr4(0,0,0,0)*x - 192.D0*Hr4(0,0,0,0)*dp - 64.D0* & + & Hr4(0,0,0,0)*dm + 144.D0*Hr4(0,0,0,1) - 240.D0*Hr4(0,0,0,1)*x & + & - 384.D0*Hr4(0,0,0,1)*dp ) + gqq2 = gqq2 + cf**3 * ( 64.D0*Hr4(0,0,0,1)*dm - 64.D0*Hr4(0,0,1,0 & + & ) - 128.D0*Hr4(0,0,1,0)*x - 64.D0*Hr4(0,0,1,0)*dp + 128.D0* & + & Hr4(0,0,1,0)*dm - 64.D0*Hr4(0,0,1,1) - 64.D0*Hr4(0,0,1,1)*x & + & + 128.D0*Hr4(0,0,1,1)*dm - 80.D0*Hr4(0,1,0,0) - 80.D0*Hr4(0, & + & 1,0,0)*x + 64.D0*Hr4(0,1,0,0)*dm - 64.D0*Hr4(0,1,0,1) - 64.D0 & + & *Hr4(0,1,0,1)*x + 128.D0*Hr4(0,1,0,1)*dm - 64.D0*Hr4(0,1,1,0) & + & - 64.D0*Hr4(0,1,1,0)*x + 128.D0*Hr4(0,1,1,0)*dm - 128.D0* & + & Hr4(1,0,-1,0) - 128.D0*Hr4(1,0,-1,0)*x + 256.D0*Hr4(1,0,-1,0) & + & *dm + 64.D0*Hr4(1,0,0,0) + 64.D0*Hr4(1,0,0,0)*x - 128.D0*Hr4( & + & 1,0,0,0)*dm - 128.D0*Hr4(1,0,0,1) - 128.D0*Hr4(1,0,0,1)*x + & + & 256.D0*Hr4(1,0,0,1)*dm - 64.D0*Hr4(1,0,1,0) - 64.D0*Hr4(1,0,1 & + & ,0)*x + 128.D0*Hr4(1,0,1,0)*dm ) + gqq2 = gqq2 + nf*cf*ca * ( - 1034.D0/9.D0 + 3938.D0/27.D0*x - & + & 836.D0/27.D0*dm + 32.D0*z3 + 16.D0*z3*x - 16.D0*z3*dp - 48.D0 & + & *z3*dm - 88.D0/9.D0*z2 - 8.D0/3.D0*z2*x + 160.D0/9.D0*z2*dp & + & + 160.D0/9.D0*z2*dm - 32.D0/3.D0*Hr1(-1)*z2 + 32.D0/3.D0* & + & Hr1(-1)*z2*x + 64.D0/3.D0*Hr1(-1)*z2*dp - 916.D0/27.D0*Hr1(0) & + & + 716.D0/27.D0*Hr1(0)*x - 1336.D0/27.D0*Hr1(0)*dm - 8.D0/3.D0& + & *Hr1(0)*z2 - 8.D0*Hr1(0)*z2*x - 16.D0/3.D0*Hr1(0)*z2*dp + 32.D& + & 0/3.D0*Hr1(0)*z2*dm + 16.D0/3.D0*Hr1(1) - 16.D0/3.D0*Hr1(1)*x & + & - 64.D0/9.D0*Hr2(-1,0) + 256.D0/9.D0*Hr2(-1,0)*x + 320.D0/9.D& + & 0*Hr2(-1,0)*dp + 104.D0/9.D0*Hr2(0,0) - 32.D0/9.D0*Hr2(0,0)*x & + & - 160.D0/9.D0*Hr2(0,0)*dp - 112.D0/3.D0*Hr2(0,0)*dm + 8.D0/3.& + & D0*Hr2(0,1) + 8.D0/3.D0*Hr2(0,1)*x - 16.D0/3.D0*Hr3(-1,0,0) & + & + 16.D0/3.D0*Hr3(-1,0,0)*x + 32.D0/3.D0*Hr3(-1,0,0)*dp + 32.D& + & 0/3.D0*Hr3(-1,0,1) - 32.D0/3.D0*Hr3(-1,0,1)*x - 64.D0/3.D0* & + & Hr3(-1,0,1)*dp - 16.D0/3.D0*Hr3(0,-1,0) + 16.D0/3.D0*Hr3(0,-1 & + & ,0)*x ) + gqq2 = gqq2 + nf*cf*ca * ( 32.D0/3.D0*Hr3(0,-1,0)*dp + 32.D0/3.D0 & + & *Hr3(0,0,0) - 32.D0/3.D0*Hr3(0,0,0)*dp - 32.D0/3.D0*Hr3(0,0,0 & + & )*dm - 8.D0/3.D0*Hr3(0,0,1) + 8.D0*Hr3(0,0,1)*x + 32.D0/3.D0* & + & Hr3(0,0,1)*dp - 16.D0/3.D0*Hr3(0,0,1)*dm - 8.D0*Hr3(1,0,0) - & + & 8.D0*Hr3(1,0,0)*x + 16.D0*Hr3(1,0,0)*dm ) + gqq2 = gqq2 + nf*cf**2 * ( 109.D0 - 217.D0/3.D0*x - 110.D0/3.D0* & + & dm - 128.D0/3.D0*z3 - 32.D0/3.D0*z3*x + 32.D0*z3*dp + 160.D0/ & + & 3.D0*z3*dm + 160.D0/9.D0*z2 - 160.D0/9.D0*z2*x - 320.D0/9.D0* & + & z2*dp + 64.D0/3.D0*Hr1(-1)*z2 - 64.D0/3.D0*Hr1(-1)*z2*x - 128.& + & D0/3.D0*Hr1(-1)*z2*dp + 508.D0/9.D0*Hr1(0) + 476.D0/9.D0*Hr1( & + & 0)*x + 20.D0/3.D0*Hr1(0)*dm - 32.D0/3.D0*Hr1(0)*z2 + 32.D0/3.D& + & 0*Hr1(0)*z2*dp + 32.D0/3.D0*Hr1(0)*z2*dm - 64.D0/3.D0*Hr1(1) & + & + 64.D0/3.D0*Hr1(1)*x + 128.D0/9.D0*Hr2(-1,0) - 512.D0/9.D0* & + & Hr2(-1,0)*x - 640.D0/9.D0*Hr2(-1,0)*dp + 16.D0/9.D0*Hr2(0,0) & + & + 176.D0/3.D0*Hr2(0,0)*x + 320.D0/9.D0*Hr2(0,0)*dp + 16.D0* & + & Hr2(0,0)*dm - 32.D0/9.D0*Hr2(0,1) + 160.D0/9.D0*Hr2(0,1)*x - & + & 320.D0/9.D0*Hr2(0,1)*dm + 64.D0/9.D0*Hr2(1,0) + 256.D0/9.D0* & + & Hr2(1,0)*x - 320.D0/9.D0*Hr2(1,0)*dm + 32.D0/3.D0*Hr3(-1,0,0) & + & - 32.D0/3.D0*Hr3(-1,0,0)*x - 64.D0/3.D0*Hr3(-1,0,0)*dp - 64.D& + & 0/3.D0*Hr3(-1,0,1) + 64.D0/3.D0*Hr3(-1,0,1)*x + 128.D0/3.D0* & + & Hr3(-1,0,1)*dp ) + gqq2 = gqq2 + nf*cf**2 * ( 32.D0/3.D0*Hr3(0,-1,0) - 32.D0/3.D0* & + & Hr3(0,-1,0)*x - 64.D0/3.D0*Hr3(0,-1,0)*dp + 8.D0/3.D0*Hr3(0,0 & + & ,0) + 24.D0*Hr3(0,0,0)*x + 64.D0/3.D0*Hr3(0,0,0)*dp - 32.D0/3.& + & D0*Hr3(0,0,0)*dm + 64.D0/3.D0*Hr3(0,0,1) - 64.D0/3.D0*Hr3(0,0 & + & ,1)*dp - 64.D0/3.D0*Hr3(0,0,1)*dm + 32.D0/3.D0*Hr3(0,1,0) + & + & 32.D0/3.D0*Hr3(0,1,0)*x - 64.D0/3.D0*Hr3(0,1,0)*dm + 64.D0/3.D& + & 0*Hr3(1,0,0) + 64.D0/3.D0*Hr3(1,0,0)*x - 128.D0/3.D0*Hr3(1,0, & + & 0)*dm ) + gqq2 = gqq2 + nf**2*cf * ( 112.D0/27.D0 - 32.D0/9.D0*x - 16.D0/27.& + & D0*dm + 8.D0/27.D0*Hr1(0) - 88.D0/27.D0*Hr1(0)*x + 80.D0/27.D0& + & *Hr1(0)*dm - 8.D0/9.D0*Hr2(0,0) - 8.D0/9.D0*Hr2(0,0)*x + 16.D0& + & /9.D0*Hr2(0,0)*dm ) +! +! ...The soft (`+'-distribution) part of the splitting function +! + ! GPS: now included from module qcd +! A3 = & +! & ca**2*cf * ( + 490.D0/3.D0 + 88.D0/3.D0*z3 - 1072.D0/9.D0*z2& +! & + 176.D0/5.D0*z2**2 ) & +! & + ca*cf*nf * ( - 836./27.D0 + 160./9.D0*z2 - 112./3.D0*z3 ) & +! & + cf**2*nf * ( - 110./3.D0 + 32.*z3 ) - cf*nf2 * 16./27.D0 +! + GQQ2L = DM * A3 +! +! ...The regular piece of the splitting function +! + X2NSMA = GQQ2 - GQQ2L +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the singular (soft) piece. +! + FUNCTION X2NSB (Y, NF) + IMPLICIT REAL*8 (A - Z) + INTEGER NF +! +! COMMON / P2SOFT / A3 +! + X2NSB = A3/(1.D0-Y) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the 'local' piece. +! + FUNCTION X2NSC (Y, NF) +! + IMPLICIT REAL*8 (A - Z) + INTEGER NF, NF2 + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0, & + & Z5 = 1.0369 27755 14336 99263 D0 ) +! +! COMMON / P2SOFT / A3 +! +! ...Colour factors +! + !CF = 4./3.D0 + !CA = 3.D0 + NF2 = NF*NF +! +! ...The coefficient of delta(1-x) +! + P2DELT = & + & + 29.D0/2.D0*cf**3 & + & + 151.D0/4.D0*ca*cf**2 & + & - 1657.D0/36.D0*ca**2*cf & + & - 240.D0*z5*cf**3 & + & + 120.D0*z5*ca*cf**2 & + & + 40.D0*z5*ca**2*cf & + & + 68.D0*z3*cf**3 & + & + 844.D0/3.D0*z3*ca*cf**2 & + & - 1552.D0/9.D0*z3*ca**2*cf & + & + 18.D0*z2*cf**3 & + & - 410.D0/3.D0*z2*ca*cf**2 & + & + 4496.D0/27.D0*z2*ca**2*cf & + & - 32.D0*z2*z3*cf**3 & + & + 16.D0*z2*z3*ca*cf**2 & + & + 288.D0/5.D0*z2**2*cf**3 & + & - 988.D0/15.D0*z2**2*ca*cf**2 & + & - 2.D0*z2**2*ca**2*cf & + & - 1336.D0/27.D0*z2*ca*cf*nf & + & + 4.D0/5.D0*z2**2*ca*cf*nf & + & + 200.D0/9.D0*z3*ca*cf*nf & + & + 20.D0*ca*cf*nf & + & + 20.D0/3.D0*z2*cf**2*nf & + & + 232.D0/15.D0*z2**2*cf**2*nf & + & - 136.D0/3.D0*z3*cf**2*nf & + & - 23.D0*cf**2*nf & + & + 80.D0/27.D0*z2*cf*nf2 & + & - 16.D0/9.D0*z3*cf*nf2 & + & - 17.D0/9.D0*cf*nf2 +! +! + X2NSC = LOG (1.D0-Y) * A3 + P2DELT +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is P_NSS, the difference of P_NSV and P_NS-. +! + FUNCTION X2NSSA (X, NF) +! + IMPLICIT REAL*8 (A - Z) + COMPLEX*16 HC1, HC2, HC3, HC4 + INTEGER NF, NF2, N1, N2, NW, I1, I2, I3, N + PARAMETER ( N1 = -1, N2 = 1, NW = 4 ) + DIMENSION HC1(N1:N2),HC2(N1:N2,N1:N2),HC3(N1:N2,N1:N2,N1:N2), & + & HC4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HR1(N1:N2),HR2(N1:N2,N1:N2),HR3(N1:N2,N1:N2,N1:N2), & + & HR4(N1:N2,N1:N2,N1:N2,N1:N2) + DIMENSION HI1(N1:N2),HI2(N1:N2,N1:N2),HI3(N1:N2,N1:N2,N1:N2), & + & HI4(N1:N2,N1:N2,N1:N2,N1:N2) + PARAMETER ( Z2 = 1.6449 34066 84822 64365 D0, & + & Z3 = 1.2020 56903 15959 42854 D0, & + & Z5 = 1.0369 27755 14336 99263 D0 ) +! +! ...Some abbreviations +! + DX = 1.D0/X + DM = 1.D0/(1.D0-X) + DP = 1.D0/(1.D0+X) +! +! ...The harmonic polylogs up to weight 4 by Gehrmann and Remiddi +! + CALL HPLOG (X, NW, HC1,HC2,HC3,HC4, HR1,HR2,HR3,HR4, & + & HI1,HI2,HI3,HI4, N1, N2) +! +! ...The splitting function in terms of the harmonic polylogs +! + gqq2 = & + & + 5./18.D0 * NF * ( 6400.D0/3.D0 - 6400.D0/3.D0*x + 256.D0*z3 & + & + 1280.D0/3.D0*z3*x**2 - 2144.D0/3.D0*z2 - 1312.D0/3.D0*z2*x & + & + 96.D0*z2**2 + 160.D0*z2**2*x - 192.D0*Hr1(-1)*z2 - 192.D0* & + & Hr1(-1)*z2*x - 256.D0*Hr1(-1)*z2*x**2 - 256.D0*Hr1(-1)*z2*dx & + & + 3200.D0/3.D0*Hr1(0) + 96.D0*Hr1(0)*x - 256.D0*Hr1(0)*z3 + & + & 32.D0*Hr1(0)*z2 + 288.D0*Hr1(0)*z2*x + 1024.D0/3.D0*Hr1(0)*z2 & + & *x**2 + 2912.D0/3.D0*Hr1(1) - 2912.D0/3.D0*Hr1(1)*x - 64.D0* & + & Hr1(1)*z2 + 64.D0*Hr1(1)*z2*x + 256.D0/3.D0*Hr1(1)*z2*x**2 - & + & 256.D0/3.D0*Hr1(1)*z2*dx - 832.D0/3.D0*Hr2(-1,0) - 832.D0/3.D0& + & *Hr2(-1,0)*x + 128.D0*Hr2(0,-1)*z2 - 128.D0*Hr2(0,-1)*z2*x + & + & 1216.D0/3.D0*Hr2(0,0) + 928.D0/3.D0*Hr2(0,0)*x - 320.D0*Hr2(0 & + & ,0)*z2 - 192.D0*Hr2(0,0)*z2*x + 1312.D0/3.D0*Hr2(0,1) + 1312.D& + & 0/3.D0*Hr2(0,1)*x - 128.D0*Hr2(0,1)*z2 - 128.D0*Hr2(0,1)*z2*x & + & + 128.D0*Hr3(-1,-1,0) + 128.D0*Hr3(-1,-1,0)*x - 512.D0/3.D0* & + & Hr3(-1,-1,0)*x**2 - 512.D0/3.D0*Hr3(-1,-1,0)*dx + 64.D0*Hr3( & + & -1,0,0) ) + gqq2 = gqq2 + 5./18.D0 * NF* ( 64.D0*Hr3(-1,0,0)*x + 512.D0/3.D & + & 0*Hr3(-1,0,0)*x**2 + 512.D0/3.D0*Hr3(-1,0,0)*dx + 256.D0*Hr3( & + & -1,0,1) + 256.D0*Hr3(-1,0,1)*x + 512.D0/3.D0*Hr3(-1,0,1)*x**2 & + & + 512.D0/3.D0*Hr3(-1,0,1)*dx + 64.D0*Hr3(0,-1,0) - 192.D0* & + & Hr3(0,-1,0)*x + 512.D0/3.D0*Hr3(0,-1,0)*x**2 - 64.D0*Hr3(0,0, & + & 0) - 512.D0/3.D0*Hr3(0,0,0)*x**2 + 32.D0*Hr3(0,0,1) - 288.D0* & + & Hr3(0,0,1)*x - 512.D0/3.D0*Hr3(0,0,1)*x**2 - 96.D0*Hr3(1,0,0) & + & + 96.D0*Hr3(1,0,0)*x + 256.D0*Hr4(0,-1,-1,0) - 256.D0*Hr4(0, & + & -1,-1,0)*x - 128.D0*Hr4(0,-1,0,0) + 128.D0*Hr4(0,-1,0,0)*x - & + & 128.D0*Hr4(0,0,-1,0) + 128.D0*Hr4(0,0,-1,0)*x + 128.D0*Hr4(0, & + & 0,0,0) + 192.D0*Hr4(0,0,0,1) + 192.D0*Hr4(0,0,0,1)*x - 64.D0* & + & Hr4(0,1,0,0) - 64.D0*Hr4(0,1,0,0)*x ) +! + X2NSSA = GQQ2 +! + RETURN + END FUNCTION + end module xpns2e diff --git a/src/xpns2n.f90 b/src/xpns2n.f90 new file mode 100644 index 0000000..9c28182 --- /dev/null +++ b/src/xpns2n.f90 @@ -0,0 +1,253 @@ +! $Id: xpns2n.f90,v 1.3 2004/06/01 09:30:28 salam Exp $ +! Automatically generated from f77 file, with addition of "d0" +! and the placement inside a module. +module xpns2n +character(len=*), parameter :: name_xpns2 = "xpns2n" +contains +! +! ..File: xpns2n.f UPDATE 7/2000 +! +! +! ..Parametrization of the 3-loop MS(bar) splitting functions P_NS^(2) +! for the evolution of unpolarized non-singlet partons, mu_r = mu_f. +! The expansion parameter is alpha_s/(4 pi). +! +! ..The two sets spanning the error estimate are called via IMODN = 1 +! and IMODN = 2.0d0 Any other value of IMODN invokes their average. +! +! ..The distributions (in the mathematical sense) are given as in eq. +! (B.27) of Floratos, Kounnas, Lacaze: Nucl. Phys. B192 (1981) 417.0d0 +! The name-endings A, B, and C of the functions below correspond to +! the kernel superscripts [2], [3], and [1] in that equation. +! +! ..The P^+ results are based on the lowest six even-integer moments +! calculated by Larin et al. and Retey and Vermaseren. The P^- and +! P^S = P^V - P^-) approximations use the seven lowest odd-integer +! moments computed also by Retey and Vermaseren. Also used for P^+ +! and P^- are the leading small-x terms (ln^4 x) as obtained by +! Blumlein and Vogt. The exact N_f^2 term has been derived by Gracey. +! +! ..Reference: W.L. van Neerven and A. Vogt, +! hep-ph/9907472 and hep-ph/0007362 +! It is appropriate to cite also the above-mentioned sources of +! information, i.e, ref. [2-4] and [6,7] of hep-ph/0007362.0d0 +! +! +! ===================================================================== +! +! +! ..This is the regular piece of P^(2)+. +! + FUNCTION P2NSPA (Y, NF, IMODN) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMODN, NF + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + G2NSPA1 = - 1047.590d0 * DL1 + 843.884d0 * Y**2 + 98.65d0 * (1.0d0-Y) & + & + 33.71d0 * DL**2 - 1.580d0 * DL**3 * (DL + 4.0d0) & + & + NF* (- 9.649d0 * DL1**2 - 406.171d0 * Y**2 - 32.218d0 * (1.0d0-Y) & + & - 5.976d0 * DL**2 - 1.60d0 * DL**3 ) + G2NSPA2 = 147.692d0 * DL1**2 + 2602.738d0 * Y**2 + 170.11d0 & + & - 148.47d0 * DL - 1.580d0 * DL**3 * (DL - 4.0d0) & + & + NF* ( 89.941d0 * DL1 - 218.482d0 * Y**2 - 9.623d0 & + & - 0.910d0* DL**2 + 1.60d0 * DL**3 ) +! + IF (IMODN .EQ. 1) THEN + G2NSPA = G2NSPA1 + ELSE IF (IMODN .EQ. 2) THEN + G2NSPA = G2NSPA2 + ELSE + G2NSPA = 0.5d0 * (G2NSPA1 + G2NSPA2) + END IF +! + G2NSPA = G2NSPA & + & + NF**2* (- 32.0d0* Y*DL/(1.0d0-Y) * (3.0d0* DL + 10.0d0) - 64.0d0 & + & - (48.0d0* DL**2 + 352.0d0* DL + 384.0d0) * (1.0d0-Y) )/81.0d0 + P2NSPA = -G2NSPA +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! ..This is the regular piece of P^(2)-. +! + FUNCTION P2NSMA (Y, NF, IMODN) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMODN, NF + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) +! + G2NSMA1 = 157.387d0 * DL1**2 + 2741.42d0 * Y**2 + 490.43d0 * (1.0d0-Y) & + & - 67.0d0 * DL**2 - 10.005d0 * DL**3 - 1.432d0 * DL**4 & + & + NF *(- 17.989d0 * DL1**2 - 355.636d0 * Y**2 + 73.407d0 *(1.0d0-Y)*DL1& + & - 11.491d0 * DL**2 - 1.928d0 * DL**3 ) + G2NSMA2 = -115.099d0 * DL1**2 - 1581.05d0 * DL1 - 267.33d0 * (1.0d0-Y) & + & + 127.65d0 * DL**2 + 25.22d0 * DL**3 - 1.432d0 * DL**4 & + & + NF *(- 11.999d0 * DL1**2 - 397.546d0 * Y**2 - 41.949d0 * (1.0d0-Y) & + & + 1.477d0 * DL**2 + 0.538d0 * DL**3 ) +! + IF (IMODN .EQ. 1) THEN + G2NSMA = G2NSMA1 + ELSE IF (IMODN .EQ. 2) THEN + G2NSMA = G2NSMA2 + ELSE + G2NSMA = 0.5d0 * (G2NSMA1 + G2NSMA2) + END IF +! + G2NSMA = G2NSMA & + & + NF**2* (- 32.0d0* Y*DL/(1.0d0-Y) * (3.0d0* DL + 10.0d0) - 64.0d0 & + & - (48.0d0* DL**2 + 352.0d0* DL + 384.0d0) * (1.0d0-Y) )/81.0d0 + P2NSMA = -G2NSMA +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! ..This is the singular NS piece for the `+' case. +! + FUNCTION P2NSPB (Y, NF, IMODN) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMODN, NF + D1 = 1.0d0/(1.0d0-Y) +! + G2NSB1 = (-1183.762d0 + NF * 183.148d0) * D1 + G2NSB2 = (-1182.774d0 + NF * 183.931d0) * D1 +! + IF (IMODN .EQ. 1) THEN + G2NSB = G2NSB1 + ELSE IF (IMODN .EQ. 2) THEN + G2NSB = G2NSB2 + ELSE + G2NSB = 0.5d0 * (G2NSB1 + G2NSB2) + END IF +! + G2NSB = G2NSB + NF**2 * 64.0d0/81.0d0 * D1 + P2NSPB = -G2NSB +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! ..This is the singular NS piece for the `-' case. +! + FUNCTION P2NSMB (Y, NF, IMODN) +! + IMPLICIT REAL*8 (A-Z) + DIMENSION CDM0(2), CDM1(2) + INTEGER IMODN, NF + DATA CDM0 / -1185.229d0, -1174.348d0 / + DATA CDM1 / 184.765d0, 183.718d0 / + D1 = 1.0d0/(1.0d0-Y) +! + G2NSB1 = (-1185.229d0 + NF * 184.765d0) * D1 + G2NSB2 = (-1174.348d0 + NF * 183.718d0) * D1 +! + IF (IMODN .EQ. 1) THEN + G2NSB = G2NSB1 + ELSE IF (IMODN .EQ. 2) THEN + G2NSB = G2NSB2 + ELSE + G2NSB = 0.5d0 * (G2NSB1 + G2NSB2) + END IF +! + G2NSB = G2NSB + NF**2 * 64.0d0/81.0d0 * D1 + P2NSMB = -G2NSB +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! ..This is the 'local' NS+ piece piece for the `+' case. +! + FUNCTION P2NSPC (Y, NF, IMODN) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMODN, NF + DATA Z2, Z3 / 1.644934067d0, 1.202056903d0 / + DL1 = LOG (1.0d0-Y) +! + G2NSC1 = (-1183.762d0 + NF* 183.148d0)* DL1 - 1347.032d0 + NF* 174.402d0 + G2NSC2 = (-1182.774d0 + NF* 183.931d0)* DL1 - 1351.088d0 + NF* 178.208d0 +! + IF (IMODN .EQ. 1) THEN + G2NSC = G2NSC1 + ELSE IF (IMODN .EQ. 2) THEN + G2NSC = G2NSC2 + ELSE + G2NSC = 0.5d0 * (G2NSC1 + G2NSC2) + END IF +! + G2NSC = G2NSC & + & + NF**2 * (16.0d0* DL1 + (51.0d0 + 48.0d0* Z3 - 80.0d0* Z2)) * 4.0d0/81.0d0 + P2NSPC = -G2NSC +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! ..This is the 'local' NS+ piece piece for the `-' case. +! + FUNCTION P2NSMC (Y, NF, IMODN) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMODN, NF + DATA Z2, Z3 / 1.644934067d0, 1.202056903d0 / + DL1 = LOG (1.0d0-Y) +! + G2NSC1 = (-1185.229d0 + NF* 184.765d0)* DL1 - 1365.458d0 + NF* 184.289d0 + G2NSC2 = (-1174.348d0 + NF* 183.718d0)* DL1 - 1286.799d0 + NF* 177.762d0 +! + IF (IMODN .EQ. 1) THEN + G2NSC = G2NSC1 + ELSE IF (IMODN .EQ. 2) THEN + G2NSC = G2NSC2 + ELSE + G2NSC = 0.5d0 * (G2NSC1 + G2NSC2) + END IF +! + G2NSC = G2NSC & + & + NF**2 * (16.0d0* DL1 + (51.0d0 + 48.0d0* Z3 - 80.0d0* Z2)) * 4.0d0/81.0d0 + P2NSMC = -G2NSC +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! ..This is P^(2)S, the difference of P^(2)V and P^(2)-. +! + FUNCTION P2NSSA (Y, NF, IMODN) +! + IMPLICIT REAL*8 (A-Z) + INTEGER IMODN, NF + DL = LOG (Y) +! + G2NSSA1 = ( 1441.57d0 * Y**2 - 12603.59d0 * Y + 15450.01d0) * (1.0d0-Y) & + & - 7876.93d0 * Y*DL**2 + 4260.29d0 * DL + 229.27d0 * DL**2 & + & - 4.4075d0 * DL**3 + G2NSSA2 = ( 704.67d0 * Y**3 - 3310.32d0 * Y**2 - 2144.81d0 * Y & + & + 244.68d0) * (1.0d0-Y) - 4490.81d0 * Y**2 * DL & + & - 42.875d0 * DL + 11.0165d0 * DL**3 +! + IF (IMODN .EQ. 1) THEN + G2NSSA = G2NSSA1 + ELSE IF (IMODN .EQ. 2) THEN + G2NSSA = G2NSSA2 + ELSE + G2NSSA = 0.5d0 * (G2NSSA1 + G2NSSA2) + END IF +! + P2NSSA = - NF * G2NSSA +! + RETURN + END FUNCTION +end module xpns2n diff --git a/src/xpns2p.f90 b/src/xpns2p.f90 new file mode 100644 index 0000000..5d489a3 --- /dev/null +++ b/src/xpns2p.f90 @@ -0,0 +1,162 @@ +! $Id: xpns2p.f90,v 1.1 2004/06/01 09:30:31 salam Exp $ +! Automatically generated from f77 file, with addition of "d0" +! and the placement inside a module. +module xpns2p +character(len=*), parameter :: name_xpns2 = "xpns2p" +contains +! +! ..File: xpns2p.f +! +! __ +! ..The parametrized 3-loop MS non-singlet splitting functions P^(2) +! for the evolution of unpolarized partons densities, mu_r = mu_f. +! The expansion parameter is alpha_s/(4 pi). +! +! ..The distributions (in the mathematical sense) are given as in eq. +! (B.26) of Floratos, Kounnas, Lacaze: Nucl. Phys. B192 (1981) 417.0d0 +! The name-endings A, B, and C of the functions below correspond to +! the kernel superscripts [2], [3], and [1] in that equation. +! +! ..The relative accuracy of these parametrizations, as well as of +! the convolution results, is better than one part in thousand. +! +! ..References: S. Moch, J. Vermaseren and A. Vogt, +! hep-ph/0209100 = Nucl. Phys. B646 (2002) 181, +! hep-ph/0403192 (submitted to Nucl. Phys. B) +! +! ===================================================================== +! +! +! ..This is the regular piece of P2_NS+. The rational coefficients are +! exact, the rest has been fitted for x between 10^-6 and 1 - 10^-6.0d0 +! The N_f^2 part is exact and was first determined in N-space by +! J.A. Gracey in Phys. Lett. B322 (1994) 141.0d0 +! + FUNCTION P2NSPA (Y, NF) + IMPLICIT REAL*8 (A - Z) + INTEGER NF +! + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) + D81 = 1.0d0/81.0d0 +! + P2NSPA = 1641.1d0 - 3135.0d0* Y + 243.6d0 * Y**2 - 522.1d0 * Y**3 & + & + 128.0d0*D81 * DL**4 + 2400.0d0*D81 * DL**3 & + & + 294.9d0 * DL**2 + 1258.0d0* DL & + & + 714.1d0 * DL1 + DL*DL1 * (563.9d0 + 256.8d0 * DL) & + & + NF * ( -197.0d0 + 381.1d0 * Y + 72.94d0 * Y**2 + 44.79d0 * Y**3 & + & - 192.0d0*D81 * DL**3 - 2608.0d0*D81 * DL**2 - 152.6d0 * DL & + & - 5120.0d0*D81 * DL1 - 56.66d0 * DL*DL1 - 1.497d0 * Y*DL**3 )& + & + NF**2 * ( 32.0d0* Y*DL/(1.0d0-Y) * (3.0d0* DL + 10.0d0) + 64.0d0 & + & + (48.0d0* DL**2 + 352.0d0* DL + 384.0d0) * (1.0d0-Y) ) * D81 +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the regular piece of P2_NS-. The rational coefficients are +! exact, the rest has been fitted for x between 10^-6 and 1 - 10^-6.0d0 +! The N_f^2 part is exact (and identical to that of P2_NS+). +! + FUNCTION P2NSMA (Y, NF) + IMPLICIT REAL*8 (A - Z) + INTEGER NF +! + DL = LOG (Y) + DL1 = LOG (1.0d0-Y) + D81 = 1.0d0/81.0d0 +! + P2NSMA = 1860.2d0 - 3505.0d0* Y + 297.0d0 * Y**2 - 433.2d0 * Y**3 & + & + 116.0d0*D81 * DL**4 + 2880.0d0*D81 * DL**3 & + & + 399.2d0 * DL**2 + 1465.2d0 * DL & + & + 714.1d0 * DL1 + DL*DL1 * (684.0d0 + 251.2d0 * DL) & + & + NF * ( -216.62d0 + 406.5d0 * Y + 77.89d0 * Y**2 + 34.76d0 * Y**3& + & - 256.0d0*D81 * DL**3 - 3216.0d0*D81 * DL**2 - 172.69d0 * DL & + & - 5120.0d0*D81 * DL1 - 65.43d0 * DL*DL1 - 1.136d0 * Y*DL**3 )& + & + NF**2 * ( 32.0d0* Y*DL/(1.0d0-Y) * (3.0d0* DL + 10.0d0) + 64.0d0 & + & + (48.0d0* DL**2 + 352.0d0* DL + 384.0d0) * (1.0d0-Y) ) * D81 +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the singular piece of both P2_NS+ and P2_NS-. It is exact +! up to the truncation of the irrational coefficients. +! + FUNCTION P2NSB (Y, NF) + IMPLICIT REAL*8 (A-Z) + INTEGER NF +! + P2NSB = ( 1174.898d0 - NF * 183.187d0 - NF**2 * 64.0d0/81.0d0 ) / (1.0d0-Y) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is the 'local' piece of P2_NS+. The coefficients of delta(1-x) +! have been partly shifted relative to the exact (truncated) values. +! + FUNCTION P2NSPC (Y, NF) + IMPLICIT REAL*8 (A - Z) + INTEGER NF +! + DL1 = LOG (1.0d0-Y) +! + P2NSPC = 1174.898d0 * DL1 + 1295.624d0 - 0.24d0 & + & - NF * ( 183.187d0 * DL1 + 173.938d0 - 0.011d0 ) & + & + NF**2 * ( - 64.0d0/81.0d0 * DL1 + 1.13067d0 ) +! + RETURN + END FUNCTION +! +! +! --------------------------------------------------------------------- +! +! +! ..This is the 'local' piece of P2_NS-. The coefficients of delta(1-x) +! have been partly shifted relative to the exact (truncated) values. +! + FUNCTION P2NSMC (Y, NF) + IMPLICIT REAL*8 (A - Z) + INTEGER NF +! + DL1 = LOG (1.0d0-Y) +! + P2NSMC = 1174.898d0 * DL1 + 1295.624d0 - 0.154d0 & + & - NF * ( 183.187d0 * DL1 + 173.938d0 - 0.005d0 ) & + & + NF**2 * ( - 64.0d0/81.0d0 * DL1 + 1.13067d0 ) +! + RETURN + END FUNCTION +! +! --------------------------------------------------------------------- +! +! +! ..This is P2_NSS, the difference of P2_NSV and P2_NS-. +! + FUNCTION P2NSSA (Y, NF) +! + IMPLICIT REAL*8 (A-Z) + INTEGER NF +! + D27 = 1.0d0/27.0d0 + DL = LOG (Y) + Y1 = 1.0d0- Y + DL1 = LOG (Y1) +! + P2NSSA = Y1* ( 151.49d0 + 44.51d0 * Y - 43.12d0 * Y**2 + 4.820d0 * Y**3 )& + & + 40.0d0*D27 * DL**4 - 80.0d0*D27 * DL**3 + 6.892d0 * DL**2 & + & + 178.04d0 * DL + DL*DL1 * ( - 173.1d0 + 46.18d0 * DL ) & + & + Y1*DL1 * ( - 163.9d0 / Y - 7.208d0 * Y ) +! + P2NSSA = NF * P2NSSA +! + RETURN + END FUNCTION +end module xpns2p diff --git a/tarit.sh b/tarit.sh new file mode 100755 index 0000000..b5689ff --- /dev/null +++ b/tarit.sh @@ -0,0 +1,33 @@ +#!/bin/zsh +# create a tar archive + +#version=0.9.0c-20050929-1200 +version=1.0 +origdir=`pwd | sed 's/.*\///'` +echo "Will make an archive of $origdir/" +dir=$origdir-$version +tarname=$dir.tgz + +pushd .. + +if [[ -e $tarname ]] +then + echo "Tarfile $tarname already exists. Not proceeding." +else + echo "Creating $tarname:" + if [[ -e $dir ]] + then + echo "Could not create $dir as link to $origdir (former exists already)" + else + ln -s $origdir $dir + tar zcvhf $tarname $dir/**/*.(f90|f|h|alg|sh|c|cc) \ + $dir/(src|example_f77|testing)/(Makefile|*.pl) \ + $dir/**/READM*[A-Z] $dir/ChangeLog + rm $dir + fi +fi + +#tar zcf $tarname +popd + + diff --git a/testing-other/Makefile b/testing-other/Makefile new file mode 100644 index 0000000..43af352 --- /dev/null +++ b/testing-other/Makefile @@ -0,0 +1,63 @@ +# Makefile generated automatically with +# /ada1/lpthe/salam/scripts/makePNEW.perl testcteq6 -lcern -L../src -lpdfconv -L/ada1/lpthe/salam/utils/LHAPDF/lib -lLHAPDF -I../src +# default program to compile +PROG = testcteq6 + +ALLPROG = testcteq6-v2 testcteq6 + +# This will be used one day... +ALLPROGSRC = testcteq6-v2.f90 testcteq6.f90 + +ALLPROGOBJ = testcteq6-v2.o testcteq6.o + +SRCS = + +POSTSRCS = + +OBJS = + +POSTOBJS = +POSTLIB = + +LIBS = -L/maia/cern/2000/lib -L../src -lpdfconv -L/ada1/lpthe/salam/utils/LHAPDF/lib -lLHAPDF -lmathlib -lkernlib -L/usr/lib/gcc-lib/i386-redhat-linux/3.2.3 -lg2c -lm + +CC = cc +CFLAGS = -O +FC = gfortran +FFLAGS = -O3 -march=i686 -I../src +F90 = gfortran +F90FLAGS = -O3 -march=i686 -I../src +LDFLAGS = + +# Trick to enable old 'make PROG=xxx' form to still work +all: $(PROG)__ + +$(PROG)__: $(PROG) + +ALL: $(ALLPROG) + +testcteq6-v2: testcteq6-v2.o $(OBJS) $(POSTOBJS) + $(F90) $(LDFLAGS) -o testcteq6-v2 testcteq6-v2.o $(OBJS) $(LIBS) $(POSTOBJS) $(POSTLIB) + +testcteq6: testcteq6.o $(OBJS) $(POSTOBJS) + $(F90) $(LDFLAGS) -o testcteq6 testcteq6.o $(OBJS) $(LIBS) $(POSTOBJS) $(POSTLIB) + +libclean: + rm -f $(ALLPROGOBJS) $(OBJS) $(POSTOBJS) + +clean: + rm -f $(ALLPROGOBJS) $(OBJS) $(POSTOBJS) *.mod *.d + +realclean: + rm -f $(ALLPROG) $(ALLPROGOBJ) $(OBJS) $(POSTOBJS) *.mod *.d + +make: + /ada1/lpthe/salam/scripts/makePNEW.perl testcteq6 -lcern -L../src -lpdfconv -L/ada1/lpthe/salam/utils/LHAPDF/lib -lLHAPDF -I../src + +.SUFFIXES: $(SUFFIXES) .f90 + +%.o: %.f90 + $(F90) $(F90FLAGS) -c $< + +testcteq6-v2.o: +testcteq6.o: diff --git a/testing-other/mkmk b/testing-other/mkmk new file mode 100755 index 0000000..f2a9bb9 --- /dev/null +++ b/testing-other/mkmk @@ -0,0 +1,2 @@ +#!/bin/sh +makePNEW.perl testcteq6 -lcern -L../src -lpdfconv -L$LHAPDFDIR -lLHAPDF -I../src diff --git a/testing-other/testcteq6-v2.f90 b/testing-other/testcteq6-v2.f90 new file mode 100644 index 0000000..315e73f --- /dev/null +++ b/testing-other/testcteq6-v2.f90 @@ -0,0 +1,47 @@ +program testcteq6 + use types; use consts_dp + implicit none + !--- user info + external :: evolvePDF + real(dp) :: alphasPDF + real(dp) :: Q(3), x, lha(-6:6,3), pdf(-6:6), pdf_deriv(-6:6), dummy(-6:6) + real(dp) :: pdf_deriv_lo(-6:6), pdf_deriv_nlo(-6:6) + real(dp) :: lha_deriv(-6:6) + real(dp) :: alphas + integer :: i, nf + + ! select cteq6m1 + call InitPDFsetByName("cteq61.LHgrid") + !call InitPDFsetByName("cteq6l.LHpdf") + call InitPDF(0) + + ! start our + call dglapStart(0.1_dp, 2) ! dy and nloop + call dglapAssign(evolvePDF) + + x = 0.1_dp + Q(:) = 30.0_dp*(/ 1.01_dp,1.0_dp,1.0_dp/1.01_dp/) + do i = 1, 3 + call evolvePDF(x,Q(i),lha(:,i)) + end do + write(6,*) real(lha(:,2)) + + call dglapEval(x,Q(2),pdf) + write(6,*) real(pdf) + + + write(6,*) "deriv:" + write(6,*) "deriv:" + lha_deriv = (lha(:,3)-lha(:,1))/(two*log(Q(3)/Q(1))) + write(6,*) real(lha_deriv) + + + nf = 5 + call dglapEvalSplit(x,Q(2), 1, nf, pdf_deriv_lo) + call dglapEvalSplit(x,Q(2), 2, nf, pdf_deriv_nlo) + pdf_deriv = pdf_deriv_lo * alphasPDF(Q(2))/twopi + & + & pdf_deriv_nlo * (alphasPDF(Q(2))/twopi)**2 + write(6,*) alphasPDF(Q(2)) + write(6,*) real(pdf_deriv) + +end program testcteq6 diff --git a/testing-other/testcteq6.f90 b/testing-other/testcteq6.f90 new file mode 100644 index 0000000..5ed9dad --- /dev/null +++ b/testing-other/testcteq6.f90 @@ -0,0 +1,53 @@ +program testcteq6 + use types; use consts_dp + implicit none + !--- user info + external :: evolvePDF + real(dp) :: alphasPDF + real(dp) :: Q(3), x, lha(-6:6,3), pdf(-6:6), pdf_deriv(-6:6), dummy(-6:6) + real(dp) :: pdf_deriv_lo(-6:6), pdf_deriv_nlo(-6:6) + real(dp) :: lha_deriv(-6:6) + real(dp) :: alphas + integer :: pdf_handle, P_LO_handle, P_NLO_handle + external :: pdfconv_new_pdf, pdfconv_P_LO, pdfconv_P_NLO + integer :: pdfconv_new_pdf, pdfconv_P_LO, pdfconv_P_NLO ! return pdf handles + integer :: i + + ! select cteq6m1 + call InitPDFsetByName("cteq61.LHgrid") + !call InitPDFsetByName("cteq6l.LHpdf") + call InitPDF(0) + + ! start our + call pdfconv_start(0.1_dp, 5) ! dy and nf + + x = 0.1_dp + Q(:) = 30.0_dp*(/ 1.01_dp,1.0_dp,1.0_dp/1.01_dp/) + do i = 1, 3 + call evolvePDF(x,Q(i),lha(:,i)) + end do + write(0,*) real(lha(:,2)) + + pdf_handle = pdfconv_new_pdf(evolvePDF,Q(2)) + call pdfconv_eval_pdf(pdf_handle, x, pdf) + write(0,*) real(pdf) + + + write(0,*) "deriv:" + lha_deriv = (lha(:,3)-lha(:,1))/(two*log(Q(3)/Q(1))) + write(0,*) real(lha_deriv) + + + P_LO_handle = pdfconv_P_LO(pdf_handle) + P_NLO_handle = pdfconv_P_NLO(pdf_handle) + call pdfconv_eval_pdf(P_LO_handle, x, pdf_deriv_lo) + call pdfconv_eval_pdf(P_NLO_handle, x, pdf_deriv_nlo) + pdf_deriv = pdf_deriv_lo * alphasPDF(Q(2))/twopi + & + & pdf_deriv_nlo * (alphasPDF(Q(2))/twopi)**2 + write(0,*) alphasPDF(Q(2)) + write(0,*) real(pdf_deriv) + + + call pdfconv_release_pdf(pdf_handle) + call pdfconv_release_pdf(P_LO_handle) +end program testcteq6 diff --git a/tests/bidirectional_mass_thresholds.f90 b/tests/bidirectional_mass_thresholds.f90 new file mode 100644 index 0000000..fc299f8 --- /dev/null +++ b/tests/bidirectional_mass_thresholds.f90 @@ -0,0 +1,116 @@ +!! Program to test correct implementation of bidirectional mass thresholds. +!! +!! Run it as follows +!! +!! ./bidirectional_mass_thresholds -as 0.005 [-evop] >! bi-c0.005 +!! ./bidirectional_mass_thresholds -as 0.01 [-evop] >! bi-c0.01 +!! +!! It evolves from 1.4GeV to 1.5GeV (crossing charm threshold) and +!! back. Col 1 = y; +!! cols 2-4 = initial (/g,s,c/); +!! cols 5-7 = final (/g,s,c/); +!! +!! Given that upwards threshold were working before, test that +!! downwards ones also work is that the following combinations should +!! all be O(as^4) [since threshold = O(as^2), so non-cancelling piece +!! between up and down directions should be the square of that] +!! +!! ($5-$2) [initial glue - final glue] +!! ($6-$3) [initial strange - final strange] +!! ($7-$4) [initial charm - final charm] +!! +!! Note that in the evop formulation, because the result of a +!! convolution has frozen flavours to zero, one loses the left-over +!! "intrinsic charm" component with the -evop option. +!! +!! Tests carried out 7 May 2006 (will be revision 44) +program bidirectional_mass_thresholds + use hoppet_v1; use sub_defs_io + implicit none + type(grid_def) :: grid + type(dglap_holder) :: dh + real(dp), pointer :: pdf_init(:,:), pdf_final(:,:) + real(dp) :: Q_init, Q_mid, asQ + type(running_coupling) :: coupling + type(evln_operator) :: evop_up, evop_down + integer, parameter :: nloop = 3 + integer :: iy + logical :: use_evop + real(dp) :: y + + Q_init = 1.4_dp + Q_mid = 1.5_dp + asQ = dble_val_opt('-as') + use_evop = log_val_opt('-evop') + + call InitGridDef(grid,ymax=10.0_dp, dy=0.1_dp,order=-5) + call InitDglapHolder(grid,dh,nloop=nloop,nflo=3,nfhi=4) + + call AllocPDF(grid, pdf_init) + call AllocPDF(grid, pdf_final) + pdf_init = unpolarized_dummy_pdf(xValues(grid)) + + call InitRunningCoupling(coupling, asQ, Q_init, nloop) + + ! go up and down + if (use_evop) then + call InitEvlnOperator(dh,evop_up, coupling, Q_init, Q_mid) + call InitEvlnOperator(dh,evop_down, coupling, Q_mid, Q_init) + pdf_final = evop_down * (evop_up * pdf_init) + call Delete(evop_up) + call Delete(evop_down) + else + pdf_final = pdf_init + call EvolvePDF(dh, pdf_final, coupling, Q_init, Q_mid) + call EvolvePDF(dh, pdf_final, coupling, Q_mid, Q_init) + end if + + ! and see what's left + do iy = 1, 100 + y = iy*0.1_dp + write(6,'(f10.5,6es25.15)') y, & + & pdf_init (:,(/0,3,4/)).aty.(y.with.grid),& + & pdf_final(:,(/0,3,4/)).aty.(y.with.grid) + end do + + ! cleanup + !call Delete(grid) + call Delete(dh) + call Delete(coupling) + call Delete(pdf_init) + call Delete(pdf_final) + +contains + !====================================================================== + !! The dummy PDF suggested by Vogt as the initial condition for the + !! unpolazrized evolution + function unpolarized_dummy_pdf(xvals) result(pdf) + real(dp), intent(in) :: xvals(:) + real(dp) :: pdf(size(xvals),ncompmin:ncompmax) + real(dp) :: uv(size(xvals)), dv(size(xvals)) + real(dp) :: ubar(size(xvals)), dbar(size(xvals)) + !--------------------- + real(dp), parameter :: N_g = 1.7_dp, N_ls = 0.387975_dp + real(dp), parameter :: N_uv=5.107200_dp, N_dv = 3.064320_dp + real(dp), parameter :: N_db = half*N_ls + + pdf = zero + ! clean method for labelling as PDF as being in the human representation + call LabelPdfAsHuman(pdf) + + !-- remember that these are all xvals*q(xvals) + uv = N_uv * xvals**0.8_dp * (1-xvals)**3 + dv = N_dv * xvals**0.8_dp * (1-xvals)**4 + dbar = N_db * xvals**(-0.1_dp) * (1-xvals)**6 + ubar = dbar * (1-xvals) + pdf(:,iflv_g) = N_g * xvals**(-0.1_dp) * (1-xvals)**5 + + pdf(:,-iflv_s) = 0.2_dp*(dbar + ubar) + pdf(:, iflv_s) = pdf(:,-iflv_s) + pdf(:, iflv_u) = uv + ubar + pdf(:,-iflv_u) = ubar + pdf(:, iflv_d) = dv + dbar + pdf(:,-iflv_d) = dbar + end function unpolarized_dummy_pdf + +end program bidirectional_mass_thresholds diff --git a/tests/determine_accuracies.f90 b/tests/determine_accuracies.f90 new file mode 100644 index 0000000..f60c3c0 --- /dev/null +++ b/tests/determine_accuracies.f90 @@ -0,0 +1,647 @@ +! +! First results: in general, need to watch out for placing +! first Q bin too low, because it "cuts" the evolution +! and one doesn't really get the full result +! +! Worst channel for Q case is b+bbar +! +! Actually "best" way of testing Q evolution might be to +! rerun the evolution from scratch each time, maybe even in a +! fixed-flavour number scheme? Answers might change by a factor of +! two roughly. +! +! Where first Qval is 5.0 GeV, in a VFNS, we're basically seeing +! NB: this is all wrong.... + +! du err (always channel 11 = b+bbar, Q=5,y=0.1) +! 0.150 2.658068E-04 +! 0.100 6.027373E-05 +! 0.070 1.308940E-05 +! 0.050 4.379481E-06 +! 0.035 8.875060E-07 +! 0.025 2.433153E-07 +! +! The best channels seem to be uv,dv,ubar+dbar,s+sbar, about 6-10 +! times better. +! +! The above results correspond roughly to expectation of eps^4 +module accuracy_helper + use hoppet_v1; use sort !(not included with hoppet_v1) + implicit none + + private + + integer, parameter, public :: accflv_n = 13 + integer, parameter, public :: accflv_g = 1 ! gluon + integer, parameter, public :: accflv_sng = 2 ! singlet + integer, parameter, public :: accflv_uv = 3 ! u - ubar + integer, parameter, public :: accflv_dv = 4 ! d - dbar + integer, parameter, public :: accflv_umd = 5 ! u - d + integer, parameter, public :: accflv_Lp = 6 ! ubar + dbar + integer, parameter, public :: accflv_Lm = 7 ! ubar - dbar + integer, parameter, public :: accflv_ss = 8 ! s + sbar + integer, parameter, public :: accflv_cs = 9 ! c + cbar + integer, parameter, public :: accflv_bs = 10 ! b + bbar + integer, parameter, public :: accflv_sv = 11 ! s - sbar + integer, parameter, public :: accflv_cv = 12 ! c - cbar + integer, parameter, public :: accflv_bv = 13 ! b - bbar + + character(len=10), parameter, public :: accflv_names(accflv_n) = (/& + "gluon ", & ! accflv_g = 1 ! + "singlet ", & ! accflv_sng = 2 ! + "u-ubar ", & ! accflv_uv = 3 ! + "d-dbar ", & ! accflv_dv = 4 ! + "u-d ", & ! accflv_umd = 5 ! + "ubar+dbar", & ! accflv_Lp = 6 ! + "ubar-dbar", & ! accflv_Lm = 7 ! + "s+sbar ", & ! accflv_ss = 8 ! + "c+cbar ", & ! accflv_cs = 9 ! + "b+bbar ", & ! accflv_bs = 10 ! + "s-sbar ", & ! accflv_sv = 11 ! + "c-cbar ", & ! accflv_cv = 12 ! + "b-bbar "/) ! accflv_bv = 13 ! + + public :: FillRefTable + + real(dp), parameter :: delta_y = 0.03_dp + + interface percentiles + module procedure percentiles_1d, percentiles_2d, percentiles_3d + end interface + public :: percentiles + + public :: add_du_info + +contains + + !====================================================================== + !! given a grid return a table of distributions, and optionally + !! return a table of reference normalizations -- these are identical + !! to the distributions except when there is a nearby sign change, in + !! which case they are deduced from the average of the function + !! at y+-delta_y. + !! + !! Currently best suited to cases where all(Qvals > Qinit) + subroutine FillRefTable(grid, dh, yvals, Qvals, table, table_norm) + type(grid_def), intent(in) :: grid + type(dglap_holder), intent(in) :: dh + real(dp), intent(in) :: yvals(:), Qvals(:) + real(dp), intent(out) :: table(:,:,:) + real(dp), optional, intent(out) :: table_norm(:,:,:) + !-------------------------- + type(running_coupling) :: coupling + integer :: ny, nQ, nflv, iQ, iy + real(dp) :: lastQ, slice(-6:6) + real(dp) :: accref_yplus(accflv_n), accref_yminus(accflv_n) + real(dp), pointer :: pdf(:,:) + real(dp) :: Qinit + + ny = assert_eq(size(yvals),size(table,1),'FillRefTable') + nQ = assert_eq(size(Qvals),size(table,3),'FillRefTable') + nflv = assert_eq(accflv_n, size(table,2),'FillRefTable') + + call AllocPDF(grid, pdf) + pdf = unpolarized_dummy_pdf(xValues(grid)) + Qinit = sqrt(two) ! Vogt starting scale + + call InitRunningCoupling(coupling,alfas=0.35_dp,Q=Qinit,nloop=3) + + lastQ = Qinit + do iQ = 1, nQ + call evolvePDF(dh, pdf, coupling, lastQ, Qvals(iQ)) + lastQ = Qvals(iQ) + + do iy = 1, ny + slice = pdf(:,-6:6) .aty. (yvals(iy).with.grid) + table(iy,:,iQ) = human2acc(slice) + if (present(table_norm)) then + accref_yplus = human2acc(pdf(:,-6:6) .aty. (& + & (yvals(iQ)+delta_y).with.grid)) + accref_yminus = human2acc(pdf(:,-6:6) .aty. (& + & max(zero,yvals(iQ)-delta_y).with.grid)) + ! look out for sign changes + where(accref_yplus*accref_yminus < zero) + ! essentially take derivative as normalisation + ! ( == we will look at error on position of zero). + table_norm(iy,:,iQ) = & + & (abs(accref_yplus - accref_yminus))& + & / (two*delta_y) + else where + table_norm(iy,:,iQ) = abs(table(iy,:,iQ)) + end where + end if + end do + + end do + + ! eliminate problems associated with sign changes in Q... + ! (recall we have already taken abs value). + do iQ = 2, nQ-1 + where (table_norm(:,:,iQ) < table_norm(:,:,iQ+1) .and. & + & table_norm(:,:,iQ) < table_norm(:,:,iQ-1)) + table_norm(:,:,iQ) = half * & + & (table_norm(:,:,iQ-1)+table_norm(:,:,iQ+1)) + end where + end do + + + call Delete(coupling) + call Delete(pdf) + end subroutine FillRefTable + + + !====================================================================== + !! Given a pdf slice in "human" format, return one in the format + !! needed for our accuracy tests (marginally different from those + !! used with Vogt). + function human2acc(slice) result(accslice) + real(dp), intent(in) :: slice(ncompmin:) + real(dp) :: accslice(accflv_n) + + accslice(accflv_g ) = slice(iflv_g) + accslice(accflv_sng) = sum(slice(1:6)) + sum(slice(-6:-1)) + accslice(accflv_uv ) = slice(iflv_u ) - slice(iflv_ubar) + accslice(accflv_dv ) = slice(iflv_d ) - slice(iflv_dbar) + accslice(accflv_umd) = slice(iflv_u ) - slice(iflv_d ) + accslice(accflv_Lp ) = slice(iflv_ubar) + slice(iflv_dbar) + accslice(accflv_Lm ) = slice(iflv_ubar) - slice(iflv_dbar) + accslice(accflv_ss ) = slice(iflv_s ) + slice(iflv_sbar) + accslice(accflv_cs ) = slice(iflv_c ) + slice(iflv_cbar) + accslice(accflv_bs ) = slice(iflv_b ) + slice(iflv_bbar) + accslice(accflv_sv ) = slice(iflv_s ) - slice(iflv_sbar) + accslice(accflv_cv ) = slice(iflv_c ) - slice(iflv_cbar) + accslice(accflv_bv ) = slice(iflv_b ) - slice(iflv_bbar) + + end function human2acc + + + !====================================================================== + !! The dummy PDF suggested by Vogt as the initial condition for the + !! unpolazrized evolution + function unpolarized_dummy_pdf(xvals) result(dummy_pdf) + real(dp), intent(in) :: xvals(:) + real(dp) :: dummy_pdf(size(xvals),ncompmin:ncompmax) + real(dp) :: uv(size(xvals)), dv(size(xvals)) + real(dp) :: ubar(size(xvals)), dbar(size(xvals)) + !--------------------- + real(dp), parameter :: N_g = 1.7_dp, N_ls = 0.387975_dp + real(dp), parameter :: N_uv=5.107200_dp, N_dv = 3.064320_dp + real(dp), parameter :: N_db = half*N_ls + + dummy_pdf = zero ! automatically in human rep + + !-- remember that these are all xvals*q(xvals) + uv = N_uv * xvals**0.8_dp * (1-xvals)**3 + dv = N_dv * xvals**0.8_dp * (1-xvals)**4 + dbar = N_db * xvals**(-0.1_dp) * (1-xvals)**6 + ubar = dbar * (1-xvals) + dummy_pdf(:,iflv_g) = N_g * xvals**(-0.1_dp) * (1-xvals)**5 + + dummy_pdf(:,-iflv_s) = 0.2_dp*(dbar + ubar) + dummy_pdf(:, iflv_s) = dummy_pdf(:,-iflv_s) + dummy_pdf(:, iflv_u) = uv + ubar + dummy_pdf(:,-iflv_u) = ubar + dummy_pdf(:, iflv_d) = dv + dbar + dummy_pdf(:,-iflv_d) = dbar + end function unpolarized_dummy_pdf + + + !====================================================================== + !! Return the percentiles of array as requested in percentiles_wanted, + !! optionally masked. + !! + !! Solution used (sort compacted version of masked array) is OK if + !! mask is one-off or there are many small masks, but suboptimal if + !! one repeatedly investigates masks which are nearly always 1 [in + !! that case a better solution would be to sort the array once and + !! for all and then work out the percentiles of subsets of the + !! sorted array]. + !! + !! Percentiles should be as a fraction of 1. + function percentiles_1d(array,percentiles_wanted, mask) result(res) + real(dp), intent(in), target :: array(:), percentiles_wanted(:) + logical, intent(in), optional :: mask(:) + real(dp) :: res(size(percentiles_wanted)) + !------------------------------------------------------ + real(dp), target :: masked_array(size(array)) + real(dp), pointer :: ref_array(:) + integer :: n, i, ell, index_array(size(array)) + + if (present(mask)) then + ! make a compact copy of the masked array + ell = 0 + do i = 1, size(array) + if (mask(i)) then + ell = ell + 1 + masked_array(ell) = array(i) + end if + end do + ref_array => masked_array(1:ell) + else + ref_array => array(:) + end if + + n = size(ref_array) + forall(i = 1:n) index_array(i) = i + call indexx(ref_array, index_array(1:n)) + + forall(i = 1:size(percentiles_wanted)) + res(i) = ref_array(index_array(max(1,nint(percentiles_wanted(i)*n)))) + end forall + end function percentiles_1d + + + !====================================================================== + !! 2d version of percentiles + function percentiles_2d(array, percentiles_wanted, mask) result(res) + real(dp), intent(in), target :: array(:,:), percentiles_wanted(:) + logical, intent(in), optional :: mask(:,:) + real(dp) :: res(size(percentiles_wanted)) + !----------------------------------------------------- + real(dp), target :: masked_array(size(array)) + integer :: i, j, ell + if (present(mask)) then + ! make a compact copy of the masked array + ell = 0 + do j = 1, size(array,2) + do i = 1, size(array,1) + if (mask(i,j)) then + ell = ell + 1 + masked_array(ell) = array(i,j) + end if + end do + end do + res = percentiles(masked_array(1:ell), percentiles_wanted) + else + masked_array = reshape(array,(/ size(array) /)) + res = percentiles(masked_array, percentiles_wanted) + end if + end function percentiles_2d + + + !====================================================================== + !! 3d version of percentiles + function percentiles_3d(array, percentiles_wanted, mask) result(res) + real(dp), intent(in), target :: array(:,:,:), percentiles_wanted(:) + logical, intent(in), optional :: mask(:,:,:) + real(dp) :: res(size(percentiles_wanted)) + !----------------------------------------------------- + real(dp), target :: masked_array(size(array)) + integer :: i, j, k, ell + if (present(mask)) then + ! make a compact copy of the masked array + ell = 0 + do k = 1, size(array,3) + do j = 1, size(array,2) + do i = 1, size(array,1) + if (mask(i,j,k)) then + ell = ell + 1 + masked_array(ell) = array(i,j,k) + end if + end do + end do + end do + res = percentiles(masked_array(1:ell), percentiles_wanted) + else + masked_array = reshape(array,(/ size(array) /)) + res = percentiles(masked_array, percentiles_wanted) + end if + end function percentiles_3d + + + !====================================================================== + !! takes a grid info string and adds info on current du + subroutine add_du_info(string,du) + character(len=*), intent(inout) :: string + real(dp), optional :: du + !------------------- + character(len=80) duinfo + + write(duinfo,'("|du=",f6.4)') default_or_opt(DefaultEvolutionDu(),du) + string = trim(string)//trim(duinfo) + end subroutine add_du_info + +end module accuracy_helper + + +!====================================================================== +!! Program options +!! -du duval : establish quality of specified duval +!! -dytable : run with a table of ty +!! -big -div2 n -div3 n : loop over ymax vals, orders, dy +program determine_accuracies + use hoppet_v1; use sub_defs_io + use accuracy_helper + implicit none + real(dp) :: ymax = 12.0_dp, dy_ref, dy, du_ref + type(grid_def) :: grid_ref, grid, gridarray(5) + type(dglap_holder) :: dh_ref, dh + integer :: iy, iQ, i + integer, parameter :: ny = 443, nQ = 6, ref_order=5 + ! leave quite a large spacing otherwise with coarse Q grid we + ! learn very little... + real(dp), parameter :: Qvals(nQ) = & + & (/5.0_dp,10.0_dp,30.0_dp,100.0_dp,1000.0_dp,1e4_dp/) + real(dp), target :: yvals(ny), table(ny,accflv_n,nQ), du + real(dp), target :: reftable(ny,accflv_n,nQ), reftable_norm(ny,accflv_n,nQ) + real :: test_run_time = 0, test_init_time = 0, start_time + + character(len=80) :: grid_string_ref, grid_string_test + integer :: outdev + + if (log_val_opt('-out')) then + outdev = idev_open_opt("-out") + else + outdev = 6 + end if + + write(outdev,'(a)') '# '//trim(command_line()) + + !dy_ref = 0.0125_dp + dy_ref = dble_val_opt('-dy_ref',0.10_dp) + du_ref = dble_val_opt('-du_ref',0.01_dp) + write(0,*) 'dy_ref = ', dy_ref + write(0,*) 'du_ref = ', du_ref + call InitGridDef(gridarray(3),dy_ref/9.0_dp, 0.5_dp, ref_order) + call InitGridDef(gridarray(2),dy_ref/3.0_dp, 2.0_dp, ref_order) + call InitGridDef(gridarray(1),dy_ref, ymax, ref_order) + call InitGridDef(grid_ref, gridarray(1:3), locked=.true.) + call Delete(gridarray(1:3)) + + call InitDglapHolder(grid_ref,dh_ref,nloop=3,nflo=3,nfhi=6) + write(0,*) 'Reference initialisation done' + + ! uniform spacing (maybe non-uniform would be better?) + forall(iy=1:ny) yvals(iy) = 0.1_dp + (iy-1)*(ymax-0.1_dp)/(ny-1) + + call SetDefaultEvolutionDu(du_ref) + call GetGridInfoString(grid_ref,grid_string_ref) + call add_du_info(grid_string_ref) + + call FillRefTable(grid_ref,dh_ref,yvals,Qvals,reftable,reftable_norm) + + if (log_val_opt('-du')) then + du = dble_val_opt('-du') + call SetDefaultEvolutionDu(du) + write(outdev,*) "Evolution du = ", du + grid = grid_ref + dh = dh_ref + test_init_time = 0.0 + !call FillRefTable(grid,dh_ref,yvals,Qvals,table) + call FillRefTable_with_timings() + call printout_accuracies + end if + + + if (log_val_opt('-dytable')) then + dy = 0.4 + do + if (dy < 2*dy_ref) exit + call InitGridDef(gridarray(3),dy/9.0_dp, 0.5_dp, ref_order) + call InitGridDef(gridarray(2),dy/3.0_dp, 2.0_dp, ref_order) + call InitGridDef(gridarray(1),dy, ymax, ref_order) + call InitGridDef(grid, gridarray(1:3), locked=.true.) + call Delete(gridarray(1:3)) + + call cpu_time(start_time) + call InitDglapHolder(grid,dh,nloop=3,nflo=3,nfhi=6) + call cpu_time(test_init_time); + test_init_time = test_init_time - start_time + + !call FillRefTable(grid,dh,yvals,Qvals,table) + call FillRefTable_with_timings() + call printout_accuracies + + call Delete(grid) + call Delete(dh) + dy = dy * 0.8_dp + end do + end if + + if (log_val_opt('-big')) call big_table + +contains + + !====================================================================== + subroutine big_table + real(dp) :: inner_ymax(1:3), lcl_ymax(1:3), dyarr(3) + integer :: order1,order2,order3, divisors(1:3), orders(3) + integer, parameter :: inner_ymax_lims(2:3) = (/ 3.5_dp, 1.0_dp/) + integer :: ndone + logical :: dummy + + dummy = log_val_opt('-dummy') + ndone = 0 + + divisors(1) = 1 + divisors(2) = int_val_opt('-div2') + divisors(3) = int_val_opt('-div3') * divisors(2) + + inner_ymax(1) = ymax + + ! ymax(3) loop + inner_ymax(3) = 0.3_dp + do + if (inner_ymax(3) > inner_ymax_lims(3)) exit + + ! ymax(2) loop + inner_ymax(2) = 1.5_dp * inner_ymax(3) + do + if (inner_ymax(2) > inner_ymax_lims(2)) exit + + ! order loops + do order1 = -6, 6 + do order2 = -6, 6 + do order3 = -6, 6 + + orders = (/order1,order2,order3/) + if (any(abs(orders) < 4)) cycle + + dy = 0.5 + do + if (dy < 2*dy_ref) exit + + ! adjust things to be exactly on-grid + dyarr(1) = ymax / nint(ymax/dy) + dyarr(2:) = dyarr(1) / divisors(2:) + + lcl_ymax(1) = ymax + lcl_ymax(2:) = nint(inner_ymax(2:)/dyarr(2:))*dyarr(2:) + + ! check to make sure we have room for the orders + ! we're asking for... + !write(0,*) '-----------------------------' + !write(0,*) dy + !write(0,*) dyarr + !write(0,*) lcl_ymax + !write(0,*) orders + !write(0,*) nint(lcl_ymax/dyarr) + + if (.not.any(nint(lcl_ymax/dyarr) < abs(orders)+1)) then + call InitGridDef(gridarray(3),dyarr(3), lcl_ymax(3), order3) + call InitGridDef(gridarray(2),dyarr(2), lcl_ymax(2), order2) + call InitGridDef(gridarray(1),dyarr(1), lcl_ymax(1), order1) + call InitGridDef(grid, gridarray(1:3), locked=.true.) + call Delete(gridarray(1:3)) + + call cpu_time(start_time) + if (.not.dummy) & + &call InitDglapHolder(grid,dh,nloop=3,nflo=3,nfhi=6) + + call cpu_time(test_init_time); + test_init_time = test_init_time - start_time + + !call FillRefTable(grid,dh,yvals,Qvals,table) + if (.not.dummy) then + call FillRefTable_with_timings() + else + table = zero + end if + !call printout_accuracies + if (.not.dummy .or. mod(ndone,1000)==0) call printout_accuracies + + call Delete(grid) + if (.not.dummy) call Delete(dh) + ndone = ndone + 1 + write(0,*) ndone + end if + dy = dy * 0.8_dp + end do ! dy loop + end do + end do + end do ! order loops + + inner_ymax(2) = inner_ymax(2) + 0.3_dp + end do ! inner_ymax(2) loop + + inner_ymax(3) = inner_ymax(3) + 0.1_dp + end do ! inner_ymax(3) loop + + end subroutine big_table + + + + !====================================================================== + subroutine FillRefTable_with_timings() + real :: ref_time + integer :: nrun + call cpu_time(ref_time); nrun = 0 + do + call FillRefTable(grid,dh,yvals,Qvals,table) + call cpu_time(test_run_time); nrun = nrun + 1 + test_run_time = test_run_time - ref_time + if (test_run_time > 1.0) exit + end do + test_run_time = test_run_time / nrun + end subroutine FillRefTable_with_timings + + + !====================================================================== + !! A quick and dirty routine to print out accuracies, etc... + subroutine printout_accuracies + real(dp), pointer :: normtable(:,:,:) + logical :: ymask(ny,accflv_n,nQ) + logical :: flvmask(ny,accflv_n,nQ), flvmask2(ny,accflv_n,nQ) + integer :: iflv, posn(3,6), j + !real(dp) :: percentls(6) = (/0.0_dp,0.5_dp, 0.9_dp, 0.99_dp, 0.999_dp, 1.0_dp /) + real(dp) :: percentls(1) = (/0.99_dp/) + real(dp) :: perc_res(size(percentls),6) + + forall (iy = 1:ny) ymask(iy,:,:) = exp(-yvals(iy)) < 0.7_dp + forall (iflv = 1:accflv_n) flvmask(:,iflv,:) = iflv <=8 + forall (iflv = 1:accflv_n) flvmask2(:,iflv,:) = iflv <=5 + + ! decide whether to use our special special table designed to + ! avoid "dangerous zeros" + if (log_val_opt('-norm')) then + normtable => reftable_norm + else + normtable => reftable + end if + + where (reftable /= zero) + table = abs((table-reftable) / normtable) + elsewhere + table = zero + end where + + posn(:,1) = maxloc(table) + posn(:,2) = maxloc(table,ymask) + posn(:,3) = maxloc(table,flvmask) + posn(:,4) = maxloc(table,flvmask.and.ymask) + posn(:,5) = maxloc(table,flvmask2) + posn(:,6) = maxloc(table,flvmask2.and.ymask) + ! now get some percentiles + perc_res(:,1) = percentiles(table,percentls) + perc_res(:,2) = percentiles(table,percentls,ymask) + perc_res(:,3) = percentiles(table,percentls,flvmask) + perc_res(:,4) = percentiles(table,percentls,flvmask.and.ymask) + perc_res(:,5) = percentiles(table,percentls,flvmask2) + perc_res(:,6) = percentiles(table,percentls,flvmask2.and.ymask) + + write(outdev,'(78("="))') + write(outdev,'(a)') "Ref.: "//trim(grid_string_ref) + call GetGridInfoString(grid,grid_string_test) + call add_du_info(grid_string_test) + write(outdev,'(a)') "Test: "//trim(grid_string_test) + + write(outdev,'(a,2es9.1,2f10.5)') & + & "Summary(max(4,5);99%(3);run/s;init/s):", & + & max(table(posn(1,4),posn(2,4),posn(3,4)), & + & table(posn(1,5),posn(2,5),posn(3,5))),& + & perc_res(:,3), & + & test_run_time, & + & test_init_time + write(outdev,'(78("-"))') + + write(outdev,'("Accuracy/99%: ",es7.1," (chnl ",i2,")/",es7.1,& + &" ; x<=0.7: ",es7.1," (chnl ",i2,")/",es7.1)') & + & table(posn(1,1),posn(2,1),posn(3,1)), posn(2,1), perc_res(1,1),& + & table(posn(1,2),posn(2,2),posn(3,2)), posn(2,2), perc_res(1,2) + write(outdev,'("Acc(1-8)/99%: ",es7.1," (chnl ",i2,")/",es7.1,& + &" ; x<=0.7: ",es7.1," (chnl ",i2,")/",es7.1)') & + & table(posn(1,3),posn(2,3),posn(3,3)), posn(2,3), perc_res(1,3),& + & table(posn(1,4),posn(2,4),posn(3,4)), posn(2,4), perc_res(1,4) + write(outdev,'("Acc(1-5)/99%: ",es7.1," (chnl ",i2,")/",es7.1,& + &" ; x<=0.7: ",es7.1," (chnl ",i2,")/",es7.1)') & + & table(posn(1,5),posn(2,5),posn(3,5)), posn(2,5), perc_res(1,5),& + & table(posn(1,6),posn(2,6),posn(3,6)), posn(2,6), perc_res(1,6) + + !write(outdev,'(a,es8.1,a,i2,a,es8.1,a,i2,a)') & + ! & 'Worst acc(1-8):',table(posn(1,3),posn(2,3),posn(3,3)),& + ! & ' (channel ', posn(2,3),'); for x<=0.7:',& + ! & table(posn(1,4),posn(2,4),posn(3,4)),& + ! & ' (channel ', posn(2,4),')' + !write(outdev,'(a,es8.1,a,i2,a,es8.1,a,i2,a)') & + ! & 'Worst acc(1-5):',table(posn(1,5),posn(2,5),posn(3,5)),& + ! & ' (channel ', posn(2,5),'); for x<=0.7:',& + ! & table(posn(1,6),posn(2,6),posn(3,6)),& + ! & ' (channel ', posn(2,6),')' + !do j = 1, size(percentls) + ! write(outdev,'("percentile ",f6.3,":",6es8.1)') percentls(j), perc_res(j,:) + !end do + + + write(outdev,'(78("-"))') + write(outdev,'(a2,a12,a8,a7,a8,a8," |",a8,a7,a8,a8)') & + & "","channel","worst","y","Q","99%","x<0.7","y","Q","99%" + write(outdev,'(78("-"))') + do iflv = 1, accflv_n + posn((/1,3/),1) = maxloc(table(:,iflv,:)) + posn((/1,3/),2) = maxloc(table(:,iflv,:),ymask(:,iflv,:)) + perc_res(:,1) = percentiles(table(:,iflv,:),percentls(:)) + perc_res(:,2) = percentiles(table(:,iflv,:),percentls(:),ymask(:,iflv,:)) + write(outdev,& + &'(i2,a12,es8.1,f7.3,f8.1,es8.1," |",es8.1,f7.3,f8.1,es8.1)') & + & iflv, accflv_names(iflv), & + & table(posn(1,1),iflv,posn(3,1)),& + & yvals(posn(1,1)), Qvals(posn(3,1)),& + & perc_res(:,1), & + & table(posn(1,2),iflv,posn(3,2)),& + & yvals(posn(1,2)), Qvals(posn(3,2)),& + & perc_res(:,2) + if (iflv == 5 .or. iflv == accflv_n) write(outdev,'(78("-"))') + end do + end subroutine printout_accuracies + +end program determine_accuracies